+(defun ensure-list (x)
+ (if (listp x)
+ x
+ (list x)))
+
+
(defun !reduce (func list initial)
(if (null list)
initial
,@body))
(defun concat-two (s1 s2)
- (concatenate 'string s1 s2)))
+ (concatenate 'string s1 s2))
+
+ (defun setcar (cons new)
+ (setf (car cons) new))
+ (defun setcdr (cons new)
+ (setf (cdr cons) new)))
(defvar *newline* (string (code-char 10)))
(defun %read-char (stream)
(and (< (cdr stream) (length (car stream)))
(prog1 (char (car stream) (cdr stream))
- (incf (cdr stream)))))
+ (setcdr stream (1+ (cdr stream))))))
(defun whitespacep (ch)
(or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
(#\'
(list 'function (ls-read stream)))
(#\\
- (%read-char stream))
+ (let ((cname (read-until stream #'terminalp)))
+ (cond
+ ((string= cname "space") (char-code #\space))
+ ((string= cname "newline") (char-code #\newline))
+ (t (char-code (char cname 0))))))
(#\+
(let ((feature (read-until stream #'terminalp)))
(cond
((string= feature "common-lisp")
- (ls-read stream);ignore
+ (ls-read stream) ;ignore
(ls-read stream))
((string= feature "lispstrack")
(ls-read stream))
(t
- (error "Unknown reader form.")))))
- ))
+ (error "Unknown reader form.")))))))
(t
(let ((string (read-until stream #'terminalp)))
(if (every #'digit-char-p string)
`((lambda () ,@body)))
(define-transformation let (bindings &rest body)
- `((lambda ,(mapcar 'car bindings) ,@body)
- ,@(mapcar 'cadr bindings)))
+ (let ((bindings (mapcar #'ensure-list bindings)))
+ `((lambda ,(mapcar 'car bindings) ,@body)
+ ,@(mapcar 'cadr bindings))))
;;; A little backquote implementation without optimizations of any
;;; kind for lispstrack.
(define-compilation cdr (x)
(concat "(" (ls-compile x env fenv) ").cdr"))
+(define-compilation setcar (x new)
+ (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
+
+(define-compilation setcdr (x new)
+ (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
+
+
(define-compilation make-symbol (name)
(concat "{name: " (ls-compile name env fenv) "}"))
((integerp sexp) (integer-to-string sexp))
((stringp sexp) (concat "\"" sexp "\""))
((listp sexp)
- (let ((sexp (ls-macroexpand-1 sexp env fenv)))
- (let ((compiler-func (second (assoc (car sexp) *compilations*))))
- (if compiler-func
- (apply compiler-func env fenv (cdr sexp))
- (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
+ (if (assoc (car sexp) *compilations*)
+ (let ((comp (second (assoc (car sexp) *compilations*))))
+ (apply comp env fenv (cdr sexp)))
+ (let ((fn (cdr (assoc (car sexp) *fenv*))))
+ (if (and (listp fn) (eq (car fn) 'macro))
+ (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
+ (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
+
(defun ls-compile-toplevel (sexp)
(setq *toplevel-compilations* nil)