4 (%compile-defmacro 'defmacro
5 (lambda (name args &rest body)
7 (%compile-defmacro ',name (lambda ,args ,@body))))))
9 (defmacro defvar (name value)
12 (%compile-defvar ',name))
18 (defmacro defun (name args &rest body)
21 (%compile-defun ',name))
22 (fsetq ,name (lambda ,args ,@body))))
24 (defmacro when (condition &rest body)
25 `(if ,condition (progn ,@body)))
27 (defmacro unless (condition &rest body)
28 `(if ,condition nil (progn ,@body)))
30 (defun = (x y) (= x y))
31 (defun + (x y) (+ x y))
32 (defun - (x y) (- x y))
33 (defun * (x y) (* x y))
34 (defun / (x y) (/ x y))
35 (defun 1+ (x) (+ x 1))
36 (defun 1- (x) (- x 1))
37 (defun zerop (x) (= x 0))
38 (defun not (x) (if x nil t))
40 (defun truncate (x y) (floor (/ x y)))
42 (defun cons (x y ) (cons x y))
43 (defun car (x) (car x))
44 (defun caar (x) (car (car x)))
45 (defun cadr (x) (car (cdr x)))
46 (defun cdr (x) (cdr x))
47 (defun cdar (x) (cdr (car x)))
48 (defun cddr (x) (cdr (cdr x)))
50 (defun list (&rest args)
53 (defun append (list1 list2)
57 (append (cdr list1) list2))))
59 (defun reverse-aux (list acc)
62 (reverse-aux (cdr list) (cons (car list) acc))))
65 (reverse-aux list '()))
75 (while (not (null list))
77 (setq list (cdr list)))
80 (defun mapcar (func list)
83 (cons (funcall func (car list))
84 (mapcar func (cdr list)))))
86 (defmacro push (x place)
87 `(setq ,place (cons ,x ,place)))
89 (defvar *package* (new))
92 (let ((s (get *package* name)))
95 (set *package* name (make-symbol name)))))
97 (defun find-symbol (name)
101 (defmacro cond (&rest clausules)
104 (if (eq (caar clausules) t)
105 `(progn ,@(cdar clausules))
106 `(if ,(caar clausules)
107 (progn ,@(cdar clausules))
108 (cond ,@(cdr clausules))))))
111 (defmacro case (form &rest clausules)
112 (let ((!form (make-symbol "FORM")))
113 `(let ((,!form ,form))
115 ,@(mapcar (lambda (clausule)
116 (if (eq (car clausule) t)
118 `((eql ,!form ,(car clausule))
122 (defmacro ecase (form &rest clausules)
127 (error "ECASE expression failed."))))))
129 (defun !reduce (func list initial)
134 (funcall func initial (car list)))))
137 (defun code-char (x) x)
138 (defun char-code (x) x)
139 (defvar *newline* (string (code-char 10)))
141 (defun concat (&rest strs)
142 (!reduce (lambda (s1 s2) (concat-two s1 s2))
146 ;;; Concatenate a list of strings, with a separator
147 (defun join (list separator)
156 (join (cdr list) separator)))))
158 (defun join-trailing (list separator)
161 (concat (car list) separator (join-trailing (cdr list) separator))))
163 (defun integer-to-string (x)
167 (while (not (zerop x 0))
168 (push (mod x 10) digits)
169 (setq x (truncate x 10)))
170 (join (mapcar (lambda (d) (string (char "0123456789" d)))
174 (defmacro and (&rest forms)
186 (defmacro or (&rest forms)
195 (or ,@(cdr forms))))))
198 (defmacro prog1 (form &rest body)
199 (let ((value (make-symbol "VALUE")))
200 `(let ((,value ,form))
205 (defun char= (x y) (= x y))
208 (defun digit-char-p (x)
209 (if (and (< #\0 x) (< x #\9))
213 (defun parse-integer (string)
216 (size (string-length string)))
217 (while (< index size)
218 (setq value (+ (* value 10) (digit-char-p (char string index))))
221 (defun every (function seq)
225 (size (string-length seq)))
226 (while (and ret (< index size))
227 (unless (funcall function (char seq index))
233 (defun string= (s1 s2)
238 ;;; It is a basic Lisp reader. It does not use advanced stuff
239 ;;; intentionally, because we want to use it to bootstrap a simple
240 ;;; Lisp. The main entry point is the function `ls-read', which
241 ;;; accepts a strings as argument and return the Lisp expression.
242 (defun make-string-stream (string)
245 (defun %peek-char (stream)
246 (and (< (cdr stream) (length (car stream)))
247 (char (car stream) (cdr stream))))
249 (defun %read-char (stream)
250 (and (< (cdr stream) (length (car stream)))
251 (prog1 (char (car stream) (cdr stream))
252 (setcdr stream (1+ (cdr stream))))))
254 (defun whitespacep (ch)
255 (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
257 (defun skip-whitespaces (stream)
259 (setq ch (%peek-char stream))
260 (while (and ch (whitespacep ch))
262 (setq ch (%peek-char stream)))))
264 (defun terminalp (ch)
265 (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
268 (defun read-until (stream func)
271 (setq ch (%peek-char stream))
272 (while (not (funcall func ch))
273 (setq string (concat string (string ch)))
275 (setq ch (%peek-char stream)))
278 (defun skip-whitespaces-and-comments (stream)
280 (skip-whitespaces stream)
281 (setq ch (%peek-char stream))
282 (while (and ch (char= ch #\;))
283 (read-until stream (lambda (x) (char= x #\newline)))
284 (skip-whitespaces stream)
285 (setq ch (%peek-char stream)))))
287 (defun %read-list (stream)
288 (skip-whitespaces-and-comments stream)
289 (let ((ch (%peek-char stream)))
296 (skip-whitespaces-and-comments stream)
297 (prog1 (ls-read stream)
298 (unless (char= (%read-char stream) #\))
299 (error "')' was expected."))))
301 (cons (ls-read stream) (%read-list stream))))))
303 (defvar *eof* (make-symbol "EOF"))
304 (defun ls-read (stream)
305 (skip-whitespaces-and-comments stream)
306 (let ((ch (%peek-char stream)))
315 (list 'quote (ls-read stream)))
318 (list 'backquote (ls-read stream)))
321 (prog1 (read-until stream (lambda (ch) (char= ch #\")))
322 (%read-char stream)))
325 (if (eql (%peek-char stream) #\@)
326 (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
327 (list 'unquote (ls-read stream))))
330 (ecase (%read-char stream)
332 (list 'function (ls-read stream)))
335 (concat (string (%read-char stream))
336 (read-until stream #'terminalp))))
338 ((string= cname "space") (char-code #\space))
339 ((string= cname "newline") (char-code #\newline))
340 (t (char-code (char cname 0))))))
342 (let ((feature (read-until stream #'terminalp)))
344 ((string= feature "common-lisp")
345 (ls-read stream) ;ignore
347 ((string= feature "lispstrack")
350 (error "Unknown reader form.")))))))
352 (let ((string (read-until stream #'terminalp)))
353 (if (every #'digit-char-p string)
354 (parse-integer string)
355 (intern (string-upcase string))))))))