Changed the license to the AGPL3. Downcased all the lisp sources. Completed the READM...
[com-informatimago:com-informatimago.git] / small-cl-pgms / ibcl / ibcl.lisp
1 ;;;; Image Based Common Lisp
2 ;;;;**************************************************************************
3 ;;;;FILE:               ibcl.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    The package IBCL exports the same symbols as COMMON-LISP, but for 
10 ;;;;    some of the functions of macros modified to track of the source
11 ;;;;    of the definitions and to be able to edit them from the image,
12 ;;;;    and to save them in files.
13 ;;;;
14 ;;;;    The package IBCL-USER is a virgin package using IBCL instead of CL.
15 ;;;;
16 ;;;;    One can work at the REPL, define variables with
17 ;;;;    DEFCONSTANT, DEFVAR, DEFPARAMETER, macros with DEFMACRO,
18 ;;;;    and functions with DEFUN, edit macro and function definitions 
19 ;;;;    with ED, and save the image with SAVE-IMAGE.
20 ;;;;
21 ;;;;    The function LIST-PACKAGES-WITH-SOURCES returns a list of packages
22 ;;;;    where some of these variables or functions are defined.
23 ;;;;    The function GET-SOURCE returns the source form of the given 
24 ;;;;    variable or function.
25 ;;;;    The function SAVE-SOURCES saves the definitions in a package,
26 ;;;;    or all the definitions to a file or stream.
27 ;;;;    
28 ;;;;AUTHORS
29 ;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
30 ;;;;MODIFICATIONS
31 ;;;;    2006-07-01 <PJB> Added deftype, defclass.
32 ;;;;    2006-05-04 <PJB> Added this header. Augmented.
33 ;;;;BUGS
34 ;;;;    Missing some def* macros, like define-symbol-macro,
35 ;;;;    defconditions, defmethod, defgeneric, etc.
36 ;;;;    Missing some functions, like make-package, rename-package, etc.
37 ;;;;    See also MOP functions.
38 ;;;;LEGAL
39 ;;;;    AGPL3
40 ;;;;    
41 ;;;;    Copyright Pascal Bourguignon 2006 - 2006
42 ;;;;    
43 ;;;;    This program is free software: you can redistribute it and/or modify
44 ;;;;    it under the terms of the GNU Affero General Public License as published by
45 ;;;;    the Free Software Foundation, either version 3 of the License, or
46 ;;;;    (at your option) any later version.
47 ;;;;    
48 ;;;;    This program is distributed in the hope that it will be useful,
49 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
50 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
51 ;;;;    GNU Affero General Public License for more details.
52 ;;;;    
53 ;;;;    You should have received a copy of the GNU Affero General Public License
54 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
55 ;;;;**************************************************************************
56
57 (cl:defpackage "IMAGE-BASED-COMMON-LISP"
58   (:nicknames "IBCL")
59   (:use "COMMON-LISP")
60   ;; We some symbols from the package #+clisp "EXT" too.
61   (:shadow "DEFPACKAGE"
62            "DEFCONSTANT" "DEFVAR" "DEFPARAMETER"
63            "DEFSTRUCT" "DEFCLASS" 
64            "DEFUN" "DEFMACRO" "LAMBDA" "DEFMETHOD"
65            "ED"  "DELETE-PACKAGE"
66            #| TODO: Add define-symbol-macro, defclass, define-condition, etc...
67            make-package, etc...
68            |#)
69   #| See exports at the end. |#)
70 (in-package "IMAGE-BASED-COMMON-LISP")
71
72
73 (cl:defparameter *map* (make-hash-table) 
74   "Maps packages to (cons definitions order)")
75
76 (cl:defun delete-package (package-designator)
77   (remhash (find-package package-designator) *map*)
78   (cl:delete-package package-designator))
79
80 (cl:defmacro define-package-attribute
81     (name (package-designator record &optional (value nil value-p)) &body body)
82   (let ((pack (gensym)))
83     `(cl:defun ,name (,@(when value-p `(,value)) ,package-designator)
84        (let* ((,pack   (find-package ,package-designator))
85               (,record (gethash ,pack *map*)))
86          (if ,record
87              (progn ,@body)
88              (let ((,record (cons (make-hash-table :test (function equal)) '())))
89                (setf (gethash ,pack *map*) ,record)
90                ,@body))))))
91
92
93 (define-package-attribute definitions  (package-designator record) (car record))
94 (define-package-attribute order        (package-designator record) (cdr record))
95 (define-package-attribute (setf order) (package-designator record value)
96   (setf (cdr record) value))
97
98 #||
99 (cl:defun definitions (package-designator)
100   (let ((record (gethash (find-package package-designator) *map*)))
101     (if record
102         (car record)
103         (let ((record (cons (make-hash-table :test (function equal)) '())))
104           (setf (gethash (find-package package-designator) *map*) record)
105           (car record)))))
106
107 (cl:defun order (package-designator)
108   (let ((record (gethash (find-package package-designator) *map*)))
109     (if record
110         (cdr record)
111         (let ((record (cons (make-hash-table :test (function equal)) '())))
112           (setf (gethash (find-package package-designator) *map*) record)
113           (cdr record)))))
114
115 (cl:defun (setf order) (value package-designator)
116   (let ((record (gethash (find-package package-designator) *map*)))
117     (if record
118         (setf (cdr record) value)
119         (let ((record (cons (make-hash-table :test (function equal)) '())))
120           (setf (gethash (find-package package-designator) *map*) record)
121           (setf (cdr record) value)))))
122 ||#
123
124 (cl:defmacro push-on-top (value place &key (test (function eql)) 
125                                 &environment env)
126   (multiple-value-bind (vars vals store-vars writer-form reader-form)
127       (get-setf-expansion place env)
128     (let ((vvalue (gensym)))
129       `(let* ((,vvalue ,value)
130               ,@(mapcar (function list) vars vals)
131               (,(car store-vars)  (cons ,vvalue (delete ,vvalue ,reader-form
132                                                         :test ,test))))
133          ,writer-form))))
134
135
136 ;;          makunbound                                 function
137 ;;          fmakunbound                                function
138 ;;          delete-package                             function
139 ;;          ...
140 ;;
141 ;; done     DEFCLASS                                   macro
142 ;; done     DEFCONSTANT                                macro
143 ;;          DEFGENERIC                                 macro
144 ;;          DEFINE-COMPILER-MACRO                      macro
145 ;;          DEFINE-CONDITION                           macro
146 ;;          DEFINE-METHOD-COMBINATION                  macro
147 ;;          DEFINE-MODIFY-MACRO                        macro
148 ;;          DEFINE-SETF-EXPANDER                       macro
149 ;;          DEFINE-SYMBOL-MACRO                        macro
150 ;; done     DEFMACRO                                   macro
151 ;;          DEFMETHOD                                  macro
152 ;; done     DEFPACKAGE                                 macro
153 ;; done     DEFPARAMETER                               macro
154 ;;          DEFSETF                                    macro
155 ;; done     DEFSTRUCT                                  macro
156 ;; done     DEFTYPE                                    macro
157 ;; done     DEFUN                                      macro
158 ;; done     DEFVAR                                     macro
159
160
161 (cl:defmacro defconstant (name value 
162                                &optional (documentation nil documentation-p))
163   (let ((key (gensym))
164         (def (gensym)))
165     `(let ((,key (cons 'variable ',name))
166            (,def (definitions ',(symbol-package name))))
167        (setf (gethash ,key ,def)
168              (list 'defconstant ',name ',value
169                    ,@(when documentation-p `(',documentation))))
170        (pushnew ,key (order ,(symbol-package name)) :test (function equal))
171        (cl:defconstant ,name ,value
172          ,@(when documentation-p `(,documentation))))))
173
174
175 (cl:defmacro defvar (name &optional (value nil value-p) 
176                           (documentation nil documentation-p))
177   (let ((key (gensym))
178         (def (gensym)))
179     `(let ((,key (cons 'variable ',name))
180            (,def (definitions ,(symbol-package name))))
181        (setf (gethash ,key ,def)
182              (list 'defvar ',name
183                    ,@ (when value-p 
184                         `(',value ,@(when documentation-p `(',documentation))))))
185        (pushnew ,key (order ,(symbol-package name)) :test (function equal))
186        (cl:defvar ,name
187          ,@ (when value-p 
188               `(,value ,@(when documentation-p `(,documentation))))))))
189
190
191 (cl:defmacro defparameter (name value 
192                                 &optional (documentation nil documentation-p))
193   (let ((key (gensym))
194         (def (gensym)))
195     `(let ((,key (cons 'variable ',name))
196            (,def (definitions ,(symbol-package name))))
197        (setf (gethash ,key ,def)
198              (list 'defparameter ',name ',value
199                    ,@(when documentation-p `(',documentation))))
200        (pushnew ,key (order ,(symbol-package name)) :test (function equal))
201        (cl:defparameter ,name ,value
202          ,@(when documentation-p `(,documentation))))))
203
204
205
206 (cl:defmacro defstruct (name-and-options &rest fields)
207   (let ((key (gensym))
208         (def (gensym))
209         (name (if (consp name-and-options) 
210                   (first name-and-options)
211                   name-and-options)))
212     `(let ((,key (cons 'type ',name))
213            (,def (definitions ,(symbol-package name))))
214        (cl:defstruct ,name-and-options ,@fields)
215        (setf (gethash ,key ,def) '(defstruct ,name-and-options ,@fields))
216        (pushnew ,key (order ,(symbol-package name)) :test (function equal))
217        ',name)))
218
219
220 (cl:defmacro defclass (name superclasses attributes &rest options)
221   (let ((key (gensym))
222         (def (gensym)))
223     `(let ((,key (cons 'type ',name))
224            (,def (definitions ,(symbol-package name))))
225        (cl:defclass ,name ,superclasses ,attributes ,@options)
226        (setf (gethash ,key ,def) 
227              '(defclass ,name ,superclasses ,attributes ,@options))
228        (pushnew ,key (order ,(symbol-package name)) :test (function equal))
229        ',name)))
230
231
232 ;; Note: we compile the functions immediately, which may not be the
233 ;;       normal behavior when an interpreter is available, to 
234
235 (cl:defmacro defmacro (name args &body body)
236   (let ((key (gensym))
237         (def (gensym)))
238     `(let ((,key (cons 'function ',name))
239            (,def (definitions ,(symbol-package name))))
240        (cl:defmacro ,name ,args ,@body)
241        (eval-when (:execute)
242          (compile ',name))
243        (unless (compiled-function-p (macro-function ',name))
244          )
245        (setf (gethash ,key ,def) '(defmacro ,name ,args ,@body)
246              (gethash (cons 'function (fdefinition ',name)) ,def)  
247              (gethash ,key ,def))
248        (pushnew ,key (order ,(symbol-package name)) :test (function equal))
249        ',name)))
250
251
252 (cl:defmacro defun (name args &body body)
253   (let ((key (gensym))
254         (def (gensym)))
255     `(let ((,key (cons 'function ',name))
256            (,def (definitions ,(symbol-package name))))
257        (cl:defun ,name ,args ,@body)
258        (eval-when (:execute)
259          (compile ',name))
260        (unless (compiled-function-p (function ,name))
261          ) 
262        (setf (gethash ,key ,def) '(defun ,name ,args ,@body)
263              (gethash (cons 'function (fdefinition ',name)) ,def)  
264              (gethash ,key ,def))
265        (pushnew ,key (order ,(symbol-package name)) :test (function equal))
266        ',name)))
267
268
269 (cl:defmacro defmethod (name &body stuff-and-body)
270   (let ((key (gensym))
271         (def (gensym)))
272     ;; TODO: we should implement the overriding of methods!
273     `(let ((,key (cons 'method ',name))
274            (,def (definitions ,(symbol-package name))))
275        (cl:defmethod ,name ,@stuff-and-body)
276        (eval-when (:execute)
277          (compile ',name))
278        (unless (compiled-function-p (function ,name))
279          ) 
280        (setf (gethash ,key ,def) '(defmethod ,name ,@stuff-and-body)
281              (gethash (cons 'method (fdefinition ',name) #|add arg types here?|#) ,def)  
282              (gethash ,key ,def))
283        (pushnew ,key (order ,(symbol-package name)) :test (function equal))
284        ',name)))
285
286
287
288 ;; (cl:defmacro lambda (args &body body)
289 ;;   `(cl:function (cl:lambda ,args ,@body)))
290
291 (cl:defmacro lambda (args &body body)
292   (let ((key (gensym))
293         (def (gensym))
294         (fun (gensym))
295         (src (gensym)))
296     `(let ((,key (cons 'function ',fun))
297            (,def (definitions *package*))
298            (,fun (compile nil (cl:lambda ,args ,@body)))
299            (,src '(lambda ,args ,@body)))
300        (setf (gethash ,key ,def)                  ,src
301              (gethash (cons 'function ,fun) ,def) ,src)
302        ,fun)))
303
304
305 (defmacro defpackage (name &rest options)
306   `(cl:defpackage ,name
307      ,@(mapcar
308         (lambda (option)
309           (if (listp option)
310               (case (first option)
311                 ((:use) 
312                  (substitute "IBCL" "COMMON-LISP"
313                              (substitute "IBCL" "CL" option)))
314                 ((:shadowing-import-from :import-from)
315                  (if (member (string (second option))
316                              '("CL" "COMMON-LISP")
317                              :test (function string=))
318                      (list* (first option)
319                             "IBCL"
320                             (cddr option))
321                      option))
322                 (otherwise option))))
323         options)))
324
325 (cl:defun list-packages-with-sources ()
326   (let ((result '()))
327     (maphash (lambda (k v) (declare (ignore v)) (push k result)) *map*)
328     result))
329
330 (cl:defun get-source (name &optional kind)
331   ;; TODO: with symbol-package we cannot find fdefinitions...
332   (if (null kind)
333       (loop
334          :for kind :in '(type variable function) 
335          :collect (get-source name kind))
336       (gethash (cons kind name) (definitions (symbol-package name)))))
337
338 (cl:defun save-sources (path-or-stream &key package)
339   (labels ((save-one-package (out package)
340              (let ((*print-readably* nil)
341                    (*package* (find-package package)))
342                (loop
343                   :with def = (definitions package)
344                   :with processed = (make-hash-table :test (function equal))
345                   :for item :in (reverse (order package))
346                   :initially (pprint `(in-package ,(package-name package)) out)
347                   :unless (gethash item processed)
348                   :do (progn 
349                         (setf (gethash item processed) t)
350                         (pprint (gethash item def) out)))))
351            (save-packages (out package)
352              (if package
353                  (save-one-package out package)
354                  (dolist (package (list-packages-with-sources))
355                    (save-one-package out package)))))
356     (if (streamp path-or-stream)
357         (save-packages path-or-stream package)
358         (with-open-file (out path-or-stream
359                              :direction :output :if-exists :supersede
360                              :if-does-not-exist :create)
361           (save-packages out package))))
362   (values))
363
364 #+sbcl (require :sb-posix)
365 (cl:defun save-image (&rest args)
366   #+clisp
367   (labels ((key-present-p (key plist)
368              (and (not (null plist))
369                   (or (eq key (car plist)) (key-present-p key (cddr plist))))))
370     (let* ((keys (rest args)))
371       (unless (key-present-p :start-package keys)
372         (setf (getf keys :start-package) (find-package "IBCL-USER")))
373       (unless (key-present-p :norc keys)
374         (setf (getf keys :norc) t))
375       (apply (function ext:saveinitmem) 
376              (first args)
377              keys)))
378   #+sbcl 
379   (when (zerop (sb-posix:fork))
380       (apply (function sb-ext:save-lisp-and-die) args))
381   #-(or clisp sbcl) (error "I don't know how to save an image in ~A" 
382                            (lisp-implementation-type))
383   (values))
384
385
386 (cl:defun make-temporary-pathname ()
387   "Generate a rather unlikely filename."
388   (loop
389      :for path = (make-pathname :name (format nil "~36R" (get-universal-time))
390                                 :type "LISP"
391                                 :case :common
392                                 :defaults (user-homedir-pathname))
393      :while (probe-file path)
394      :finally (return path)))
395
396
397 (cl:defmacro handling-errors (&body body)
398   `(handler-case (progn ,@body)
399      (simple-condition 
400          (err) 
401        (format *error-output* "~&~A: ~%" (class-name (class-of err)))
402        (apply (function format) *error-output*
403               (simple-condition-format-control   err)
404               (simple-condition-format-arguments err))
405        (format *error-output* "~&"))
406      (condition 
407          (err) 
408        (format *error-output* "~&~A: ~%  ~S~%"
409                (class-name (class-of err)) err))))
410
411
412 (cl:defun ed (&optional x)
413   (typecase x
414     (null                 (cl:ed))      ; edit whatever.
415     ((or pathname string) (cl:ed x))    ; edit an external file.
416     (otherwise 
417      (let ((def (get-source x 'function)))
418        (if def
419            (let ((path (make-temporary-pathname))
420                  ;; TODO: with symbol-package we cannot find fdefinitions...
421                  (*package* (symbol-package x)))
422              (unwind-protect
423                   (progn
424                     (with-open-file (out path
425                                          :direction :output
426                                          :if-does-not-exist :create
427                                          :if-exists :error)
428                       (pprint def out))
429                     (cl:ed path)
430                     (handling-errors
431                      (with-open-file (in path)
432                        (loop
433                           :for form = (read in nil in)
434                           :until (eq form in)
435                           :do
436                           (when *load-verbose* (print form *trace-output*))
437                           (print (eval form))))))
438                (delete-file path)))
439            (cl:ed x))))))          ; try to edit the function anyways.
440
441
442 (cl:defun repl ()
443   (do ((+eof+ (gensym))
444        (hist 1 (1+ hist)))
445       (nil)
446     (format t "~%~A[~D]> " (package-name *package*) hist)
447     (handling-errors
448      (setf +++ ++   ++ +   + -   - (read *standard-input* nil +eof+))
449      (when (or (eq - +eof+)
450                (member - '((quit)(exit)(continue)) :test (function equal)))
451        (return-from repl))
452      (setf /// //   // /   / (multiple-value-list (eval -)))
453      (setf *** **   ** *   * (first /))
454      (format t "~& --> ~{~S~^ ;~%     ~}~%" /))))
455
456
457
458 ;; We must pass the symbol in a list to export CL:NIL.
459 (export (mapcar (lambda (name) (intern name "IBCL"))
460                 (append '("SAVE-IMAGE" "SAVE-SOURCES"
461                           "GET-SOURCE" "LIST-PACKAGES-WITH-SOURCES")
462                         (let ((symbols '()))
463                           (do-external-symbols (sym "COMMON-LISP")
464                             (push (string sym) symbols))
465                           symbols))))
466
467
468
469 (let ((*error-output* (make-broadcast-stream)))
470   (defpackage "IMAGE-BASED-COMMON-LISP-USER"
471     (:nicknames "IBCL-USER")
472     (:use "IMAGE-BASED-COMMON-LISP")))
473
474 (in-package "IBCL-USER")
475
476
477
478
479
480
481
482
483