:initial-value ""))
+;;;; READER
+
+;;; It is a basic Lisp reader. It does not use advanced stuff
+;;; intentionally, because we want to use it to bootstrap a simple
+;;; Lisp. The main entry point is the function `ls-read', which
+;;; accepts a strings as argument and return the Lisp expression.
+(defun make-string-stream (string)
+ (cons string 0))
+
+(defun %peek-char (stream)
+ (if (streamp stream)
+ (peek-char nil stream nil)
+ (and (< (cdr stream) (length (car stream)))
+ (char (car stream) (cdr stream)))))
+
+(defun %read-char (stream)
+ (if (streamp stream)
+ (read-char stream nil)
+ (and (< (cdr stream) (length (car stream)))
+ (prog1 (char (car stream) (cdr stream))
+ (incf (cdr stream))))))
+
+(defun whitespacep (ch)
+ (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
+
+(defun skip-whitespaces (stream)
+ (loop for ch = (%peek-char stream)
+ while (and ch (whitespacep ch))
+ do (%read-char stream)))
+
+(defun terminalp (ch)
+ (or (null ch) (whitespacep ch) (char= #\) ch)))
+
+(defun read-until (stream func)
+ (let ((string ""))
+ (loop for ch = (%peek-char stream)
+ until (funcall func ch)
+ do (setq string (concat string (string ch)))
+ do (%read-char stream))
+ string))
+
+(defun skip-whitespaces-and-comments (stream)
+ (let (ch)
+ (skip-whitespaces stream)
+ (setq ch (%peek-char stream))
+ (while (and ch (eql ch #\;))
+ (read-until stream (lambda (x) (eql x #\newline)))
+ (skip-whitespaces stream)
+ (setq ch (%peek-char stream)))))
+
+(defun %read-list (stream)
+ (skip-whitespaces-and-comments stream)
+ (let ((ch (%peek-char stream)))
+ (cond
+ ((char= ch #\))
+ (%read-char stream)
+ nil)
+ ((char= ch #\.)
+ (%read-char stream)
+ (skip-whitespaces-and-comments stream)
+ (prog1 (ls-read stream)
+ (unless (char= (%read-char stream) #\))
+ (error "')' was expected."))))
+ (t
+ (cons (ls-read stream) (%read-list stream))))))
+
+(defvar *eof* (make-symbol "EOF"))
+(defun ls-read (stream)
+ (skip-whitespaces-and-comments stream)
+ (let ((ch (%peek-char stream)))
+ (cond
+ ((null ch)
+ *eof*)
+ ((char= ch #\()
+ (%read-char stream)
+ (%read-list stream))
+ ((char= ch #\')
+ (%read-char stream)
+ (list 'quote (ls-read stream)))
+ ((char= ch #\`)
+ (%read-char stream)
+ (list 'backquote (ls-read stream)))
+ ((char= ch #\")
+ (%read-char stream)
+ (prog1 (read-until stream (lambda (ch) (char= ch #\")))
+ (%read-char stream)))
+ ((char= ch #\,)
+ (%read-char stream)
+ (if (eql (%peek-char stream) #\@)
+ (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
+ (list 'unquote (ls-read stream))))
+ ((char= ch #\#)
+ (%read-char stream)
+ (ecase (%read-char stream)
+ (#\'
+ (list 'function (ls-read stream)))))
+ (t
+ (let ((string (read-until stream #'terminalp)))
+ (if (every #'digit-char-p string)
+ (parse-integer string)
+ (intern (string-upcase string))))))))
+
+(defun ls-read-from-string (string)
+ (ls-read (make-string-stream string)))
+
+
+;;;; Compiler
+
(let ((counter 0))
(defun make-var-binding (symbol)
(cons symbol (format nil "v~d" (incf counter)))))
(ls-compile pred env fenv)
(ls-compile-block body env fenv)))
+(define-compilation function (x)
+ (cond
+ ((and (listp x) (eq (car x) 'lambda))
+ (ls-compile x env fenv))
+ ((symbolp x)
+ (lookup-function x fenv))))
+
(defmacro eval-when-compile (&body body)
`(eval-when (:compile-toplevel :execute)
,@body))
nil
*eval-when-compilations*))
+
+(defmacro define-transformation (name args form)
+ `(define-compilation ,name ,args
+ (ls-compile ,form env fenv)))
+
+(define-transformation progn (&rest body)
+ `((lambda () ,@body)))
+
+(define-transformation let (bindings &rest body)
+ `((lambda ,(mapcar 'car bindings) ,@body)
+ ,@(mapcar 'cadr bindings)))
+
;;; aritmetic primitives
(define-compilation + (x y)
(concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
(defun %compile-defmacro (name lambda)
(push (cons name (cons 'macro lambda)) *fenv*))
-(defun compile-funcall (name args env fenv)
- (format nil "~a(~{~a~^, ~})"
- (lookup-function name fenv)
- (mapcar (lambda (x) (ls-compile x env fenv)) args)))
-
(defun ls-macroexpand-1 (form &optional env fenv)
(let ((function (cdr (assoc (car form) *fenv*))))
(if (and (listp function) (eq (car function) 'macro))
(apply (eval (cdr function)) (cdr form))
form)))
+(defun compile-funcall (function args env fenv)
+ (cond
+ ((symbolp function)
+ (format nil "~a(~{~a~^, ~})"
+ (lookup-function function fenv)
+ (mapcar (lambda (x) (ls-compile x env fenv)) args)))
+ ((and (listp function) (eq (car function) 'lambda))
+ (format nil "(~a)(~{~a~^, ~})"
+ (ls-compile function env fenv)
+ (mapcar (lambda (x) (ls-compile x env fenv)) args)))
+ (t
+ (error "Invalid function designator ~a." function))))
+
(defun ls-compile (sexp &optional env fenv)
(cond
((symbolp sexp) (lookup-variable sexp env))
code)
(setq *literals* nil))))
-
(defun ls-compile-file (filename output)
(with-open-file (in filename)
(with-open-file (out output :direction :output :if-exists :supersede)
(loop
- for x = (read in nil) while x
+ for x = (ls-read in)
+ until (eq x *eof*)
for compilation = (ls-compile-toplevel x)
when compilation do (write-line (concat compilation "; ") out)))))
;;; Testing
-
(defun compile-test ()
(ls-compile-file "test.lisp" "test.js"))