lispdoc: implemented the whole URI syntax; updated URIs in all docstrings to be writt...
[com-informatimago:com-informatimago.git] / small-cl-pgms / aim-8 / aim-8.lisp
1 ;;;;****************************************************************************
2 ;;;;FILE:               aim-8.lisp
3 ;;;;LANGUAGE:           Common-Lisp
4 ;;;;SYSTEM:             Common-Lisp
5 ;;;;USER-INTERFACE:     NONE
6 ;;;;DESCRIPTION
7 ;;;;    
8 ;;;;    Implements the LISP described in AIM-8 in Common-Lisp.
9 ;;;;    Usage:  (load "aim-8.lisp") 
10 ;;;;            (aim-8:repl)
11 ;;;;    Then at the aim-8 prompt, you have LISP, plus:
12 ;;;;       (DEFINE name sexp)     corresponding to =
13 ;;;;       (RELOAD)               to reload aim-8 if you edit it.
14 ;;;;       (DUMP-ENVIRONMENT)     to dump the defined symbols.
15 ;;;;       (LOAD "path")          to load an aim-8 source. Try "aim-8.aim-8".
16 ;;;;
17 ;;;;     AIM-8 -- 4 MARCH 1959 -- J. MCCARTHY
18 ;;;;     With an addendum dated 23 MARCH 1959
19 ;;;;     ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-008.pdf
20 ;;;;
21 ;;;;AUTHORS
22 ;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
23 ;;;;MODIFICATIONS
24 ;;;;    2004-10-24 <PJB> Created.
25 ;;;;BUGS
26 ;;;;LEGAL
27 ;;;;    AGPL3
28 ;;;;    
29 ;;;;    Copyright Pascal Bourguignon 2004 - 2012
30 ;;;;    
31 ;;;;    This program is free software: you can redistribute it and/or modify
32 ;;;;    it under the terms of the GNU Affero General Public License as published by
33 ;;;;    the Free Software Foundation, either version 3 of the License, or
34 ;;;;    (at your option) any later version.
35 ;;;;    
36 ;;;;    This program is distributed in the hope that it will be useful,
37 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
38 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
39 ;;;;    GNU Affero General Public License for more details.
40 ;;;;    
41 ;;;;    You should have received a copy of the GNU Affero General Public License
42 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
43 ;;;;****************************************************************************
44
45 (defpackage "AIM-8"
46   (:use "COMMON-LISP")
47   (:export "REPL")
48   (:documentation
49    "Implements the lisp of AIM-8 -- 4 MARCH 1959 -- J. MCCARTHY
50 With an addendum dated 23 MARCH 1959
51 ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-008.pdf"))
52 (in-package "AIM-8")
53
54
55 (defparameter *environment* (make-hash-table :test (function eq)))
56 (defmacro def     (name)       `(gethash ,name *environment*))
57 (defun   %boundp  (name) (multiple-value-bind (val bnd) (def name)
58                           (declare (ignore val)) bnd))
59 (defmacro define  (name value) `(setf (gethash ',name *environment*) ',value))
60 (defun   fdefine  (name value)  (setf (gethash name *environment*) value))
61
62 (define nil ())
63 (define f   ())
64 (define t   t)
65 (define and     (lambda (a b) (cond (a (cond (b t) (t nil))) (t nil))))
66 (define or      (lambda (a b) (cond (a t) (b t) (t nil))))
67 (define not     (lambda (a)   (cond (a nil) (t t))))
68 (define maplist 
69         (lambda (x f)
70           (cond ((null x) nil)
71                 (t (combine (f x) (maplist (rest x) f))))))
72 (define subst 
73         (lambda (x y a)
74           (cond ((null a) nil)
75                 ((atom a) (cond ((eq y a) x) (t a)))
76                 (t (combine (subst x y (first a))
77                             (subst x y (rest a))))
78                 )))
79
80
81 (defun %subst (x y a)
82   (cond ((null a) nil)
83         ((atom a) (cond ((eq y a) x) (t a)))
84         (t (cons (%subst x y (first a)) (%subst x y (rest a))))))
85
86
87 (defun %subsq (x y z)
88   (cond ((null z) nil)
89         ((atom z) (cond ((eq y z) x)  (t z)))
90         ((eq (first z) 'quote) z)
91         (t (cons (%subsq x y (first z)) (%subsq x y (rest z))))))
92
93
94 (defun %evcon (c)
95   (cond ((%eval (first (first c))) (%eval (first (rest (first c)))))
96         (t (%evcon (rest c)))))
97
98
99 (defun %evlam (vars exp args)
100   (cond ((null vars) (%eval exp))
101         (t (%evlam (rest vars) (%subsq (first args) (first vars) exp)
102                    (rest args)))))
103
104
105 (defun %apply (f args) (%eval (cons f args)))
106
107
108 (defun %eval (e)
109   (cond
110     ;; begin extensions:
111     ((atom e) (cond ((%boundp e) (def e))
112                     (t (error "Undefined: ~A" (first e)))))
113     ;; end extensions.
114     (t (case (first e)
115          ((null)    (null  (%eval (first (rest e)))))
116          ((atom)    (atom  (%eval (first (rest e)))))
117          ((quote)                 (first (rest e)))
118          ((eq)      (eq    (%eval (first (rest e)))
119                            (%eval (first (rest (rest e))))))
120          ((combine) (cons  (%eval (first (rest e)))
121                            (%eval (first (rest (rest e))))))
122          ((first)   (first (%eval (first (rest e)))))
123          ((rest)    (rest  (%eval (first (rest e)))))
124          ((cond)    (%evcon (rest e)))
125          ;; begin extensions:
126          ((load)    (load  (%eval (first (rest e)))))
127          ((print)   (print (%eval (first (rest e)))))
128          ((read)    (read))
129          (otherwise
130           (cond
131             ((atom (first e))
132              (cond ((%boundp (first e)) (%apply (def (first e)) (rest e)))
133                    (t (error "Undefined: ~A" (first e)))))
134             ;; end extensions.
135             (t (case (first (first e))
136                  ((lambda) (%evlam (first (rest (first e)))
137                               (first (rest (rest (first e))))
138                               (rest e)))
139                  ((label) (%eval (cons (%subst (first e)
140                                                (first (rest (first e)))
141                                                (first (rest (rest (first e)))))
142                                        (rest e))))
143                  (otherwise (error "Invalid: ~A" (first e)))))))))))
144
145
146
147 (defun help ()
148   (format t "~&You've got:  
149     LAMBDA LABEL
150     COND AND OR NOT  COMBINE FIRST REST
151     NULL ATOM EQ NIL T QUOTE
152 Extensions:
153     DEFINE RELOAD DUMP-ENVIRONMENT LOAD
154     QUIT"))
155
156
157 (defmacro handling-errors (&body body)
158   `(handler-case (progn ,@body)
159      (simple-condition 
160       (err) 
161       (format *error-output* "~&~A: ~%" (class-name (class-of err)))
162       (apply (function format) *error-output*
163              (simple-condition-format-control   err)
164              (simple-condition-format-arguments err))
165       (format *error-output* "~&"))
166      (condition 
167       (err) 
168       (format *error-output* "~&~A: ~%  ~S~%" (class-name (class-of err)) err))))
169
170
171 (defun repl ()
172   (let ((*package* (find-package "AIM-8")))
173     (help)
174     (loop
175        (terpri)
176        (princ "AIM-8> ")
177        (handling-errors
178         (let ((sexp (read)))
179           (cond
180             ((equal sexp '(quit))
181              (format t "GOOD BYE") (return-from repl))
182             ((equal sexp '(reload))
183              (load "aim-8") (repl) (return-from repl))
184             ((equal sexp '(dump-environment))
185              (format t "~:{~16@A = ~A~%~}" 
186                      (let ((res '()))
187                        (maphash (lambda (k v) (push (list k v) res)) 
188                                 *environment*) res)))
189             ((and (listp sexp) (eq (first sexp) 'define))
190              (fdefine (second sexp) (third sexp))
191              (format t "~A" (second sexp)))
192             (t 
193              (format t "~S" (%eval sexp))))))))
194   (terpri)
195   (values))
196
197
198 (defpackage "AIM-8-USER"
199   (:use)
200   (:import-from "AIM-8"
201                 "DEFINE" "LAMBDA" "LABEL"
202                 "COND"  "COMBINE" "FIRST" "REST"
203                 "NULL" "ATOM" "EQ" "NIL" "T" "QUOTE"))
204
205 ;;;; aim-8.lisp                       --                     --          ;;;;