src/glisp/package.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP-TEMP; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: Generating a sane DEFPACKAGE for GLISP
   4 ;;;   Created: 1999-05-25
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 1999,2000 by Gilbert Baumann
   9
  10 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  11 ;;;  a copy of this software and associated documentation files (the
  12 ;;;  "Software"), to deal in the Software without restriction, including
  13 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  14 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  15 ;;;  permit persons to whom the Software is furnished to do so, subject to
  16 ;;;  the following conditions:
  17 ;;;
  18 ;;;  The above copyright notice and this permission notice shall be
  19 ;;;  included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  24 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  25 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  26 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  27 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  28
  29 (defpackage :glisp-temp (:use #:cl))
  30 (in-package :glisp-temp)
  31
  32 (defpackage :glisp (:use))
  33
  34 (eval-when (compile)
  35   (defvar *export-from-glisp*
  36     '(
  37       "DEFSUBST"
  38       "G/MAKE-STRING"
  39       "MP/MAKE-LOCK"
  40       "MP/WITH-LOCK"
  41       "WITH-TIMEOUT"
  42       "OPEN-INET-SOCKET"
  43       ;; util.lisp :
  44       "ALWAYS"
  45       "CL-BYTE-STREAM"
  46       "CL-CHAR-STREAM"
  47       "CL-STREAM"
  48       "COMPOSE"
  49       "CURRY"
  50       "FALSE"
  51       "FORCE"
  52       "G/CLOSE"
  53       "G/FINISH-OUTPUT"
  54       "G/PEEK-CHAR"
  55       "G/READ-BYTE"
  56       "G/READ-BYTE-SEQUENCE"
  57       "G/READ-CHAR"
  58       "G/READ-CHAR-SEQUENCE"
  59       "G/READ-LINE"
  60       "G/READ-LINE*"
  61       "G/UNREAD-BYTE"
  62       "G/UNREAD-CHAR"
  63       "G/WRITE-BYTE"
  64       "G/WRITE-BYTE-SEQUENCE"
  65       "G/WRITE-CHAR"
  66       "G/WRITE-STRING"
  67       "GSTREAM"
  68       "MAP-ARRAY"
  69       "MAPFCAR"
  70       "MAX*"
  71       "MAXF"
  72       "MIN*"
  73       "MINF"
  74       "MULTIPLE-VALUE-OR"
  75       "MULTIPLE-VALUE-SOME"
  76       "NCONCF"
  77       "NEQ"
  78       "PROMISE"
  79       "RCURRY"
  80       "SANIFY-STRING"
  81       "SHOW"
  82       "SPLIT-BY"
  83       "SPLIT-BY-IF"
  84       "SPLIT-BY-MEMBER"
  85       "SPLIT-STRING"
  86       "STRING-BEGIN-EQUAL"
  87       "TRUE"
  88       "UNTIL"
  89       "USE-BYTE-FOR-CHAR-STREAM-FLAVOUR"
  90       "USE-CHAR-FOR-BYTE-STREAM-FLAVOUR"
  91       "WHILE"
  92       "WHITE-SPACE-P"
  93
  94       "CL-BYTE-STREAM->GSTREAM"
  95       "CL-CHAR-STREAM->GSTREAM"
  96       "G/OPEN-INET-SOCKET"
  97       "ACCEPT-CONNECTION"
  98
  99       "FIND-TEMPORARY-FILE"
 100       "DELETE-TEMPORARY-FILE"
 101       "WITH-TEMPORARY-FILE"
 102
 103       "SET-EQUAL"
 104       "MAYBE-PARSE-INTEGER"
 105       "NOP"
 106       "WITH-STRUCTURE-SLOTS"
 107
 108       "COMPILE-FUNCALL"
 109       "FUNCALL*"
 110       "MAPC*"
 111       "VREDUCE*"
 112       "LREDUCE*"
 113       "WITH-UNIQUE-NAMES"
 114
 115       "G/MAKE-HASH-TABLE"
 116       "G/HASHGET"
 117       "G/CLRHASH"
 118       "STIR-HASH-CODES"
 119       "HASH-SEQUENCE"
 120       "HASH/STRING-EQUAL"
 121       "MAKE-STRING-EQUAL-HASH-TABLE"
 122
 123       "PRIMEP"
 124
 125       ;; match.lisp
 126       "DEFINE-MATCH-MACRO"
 127       "IF-MATCH"
 128       "GSTREAM-AS-STRING"
 129       ))
 130
 131   (defparameter *packages*
 132     #-GCL '(:common-lisp)
 133     #+GCL '(:lisp :pcl) )
 134
 135   (defparameter *gray-symbols*
 136     '("FUNDAMENTAL-STREAM"
 137       "FUNDAMENTAL-INPUT-STREAM"
 138       "FUNDAMENTAL-OUTPUT-STREAM"
 139       "FUNDAMENTAL-CHARACTER-STREAM"
 140       "FUNDAMENTAL-BINARY-STREAM"
 141       "FUNDAMENTAL-CHARACTER-INPUT-STREAM"
 142       "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM"
 143       "FUNDAMENTAL-BINARY-INPUT-STREAM"
 144
 145       "STREAM-READ-CHAR"
 146       "STREAM-UNREAD-CHAR"
 147       "STREAM-READ-CHAR-NO-HANG"
 148       "STREAM-PEEK-CHAR"
 149       "STREAM-LISTEN"
 150       "STREAM-READ-LINE"
 151       "STREAM-CLEAR-INPUT"
 152
 153       "STREAM-WRITE-CHAR"
 154       "STREAM-LINE-COLUMN"
 155       "STREAM-START-LINE-P"
 156       "STREAM-WRITE-STRING"
 157       "STREAM-TERPRI"
 158       "STREAM-FRESH-LINE"
 159       "STREAM-FINISH-OUTPUT"
 160       "STREAM-FORCE-OUTPUT"
 161       "STREAM-ADVANCE-TO-COLUMN"
 162
 163       "STREAM-READ-BYTE"
 164       "STREAM-WRITE-BYTE" ))
 165
 166   (defparameter *gray-packages*
 167     `(
 168       #+:CLISP                 ,@'(:lisp)
 169       #+:CMU                   ,@'(:ext)
 170       #+:sbcl                   ,@'(:sb-gray)
 171       #+:ALLEGRO               ,@'(:common-lisp :excl :stream)
 172       #+:HARLEQUIN-COMMON-LISP ,@'(:stream)
 173       #+:OPENMCL               ,@'(:ccl)
 174       ))
 175
 176   (defun seek-symbol (name packages)
 177     ;; Seek the a symbol named 'name' in `packages'
 178     (or (some #'(lambda (p)
 179                   (multiple-value-bind (sym res) (find-symbol name p)
 180                     (if (eql res :external)
 181                         (list sym)
 182                       nil)))
 183               packages)
 184         (progn (format T "~&There is no ~A in ~A." name packages)
 185                (finish-output)
 186                nil)))
 187
 188   (defun dump-defpackage (&aux imports export-gray)
 189     (labels ((grok (symbols packages)
 190                    (let ((res nil))
 191                      (dolist (nam symbols)
 192                        (let ((sym (seek-symbol nam packages)))
 193                          (when sym
 194                            (push (car sym) res)
 195                            (cond ((multiple-value-bind (sym2 res) (find-symbol nam :glisp)
 196                                     (and sym2 (eq res :external)))
 197                                   ;;
 198                                   (format T "~&;; ~S is pacthed." sym) )
 199                                  (t
 200                                   (setf sym (car sym))
 201                                   ;; CLISP has no (:import ..) ARG!
 202                                   (push `(:import-from
 203                                           ,(package-name (symbol-package sym))
 204                                           ,(symbol-name sym))
 205                                         imports))))))
 206                      res)))
 207       (setf export-gray (grok *gray-symbols* *gray-packages*))
 208       `(progn
 209          (defpackage "GLISP"
 210            (:use :cl)
 211            ,@imports
 212            (:export
 213             ,@(mapcar #'symbol-name export-gray)
 214             ,@*export-from-glisp*))
 215          (defpackage "GLUSER"
 216            (:use "CL" "GLISP")) )))
 217
 218   (defmacro define-glisp-package ()
 219     (dump-defpackage))
 220   )
 221
 222 (define-glisp-package)
 223