(defun concat-two (s1 s2)
(concat-two s1 s2))
- (defun mapcar (func list)
- (let* ((head (cons 'sentinel nil))
- (tail head))
- (while (not (null list))
- (let ((new (cons (funcall func (car list)) nil)))
- (rplacd tail new)
- (setq tail new
- list (cdr list))))
- (cdr head)))
+ (defmacro with-collect (&body body)
+ (let ((head (gensym))
+ (tail (gensym)))
+ `(let* ((,head (cons 'sentinel nil))
+ (,tail ,head))
+ (flet ((collect (x)
+ (rplacd ,tail (cons x nil))
+ (setq ,tail (cdr ,tail))
+ x))
+ ,@body)
+ (cdr ,head))))
+
+ (defun map1 (func list)
+ (with-collect
+ (while list
+ (collect (funcall func (car list)))
+ (setq list (cdr list)))))
+
+ (defmacro loop (&body body)
+ `(while t ,@body))
+
+ (defun mapcar (func list &rest lists)
+ (let ((lists (cons list lists)))
+ (with-collect
+ (block loop
+ (loop
+ (let ((elems (map1 #'car lists)))
+ (do ((tail lists (cdr tail)))
+ ((null tail))
+ (when (null (car tail)) (return-from loop))
+ (rplaca tail (cdar tail)))
+ (collect (apply func elems))))))))
(defun identity (x) x)
(defmacro multiple-value-list (value-from)
`(multiple-value-call #'list ,value-from))
- ;; Packages
+
+ ;;; Generalized references (SETF)
+
+ (defvar *setf-expanders* nil)
+
+ (defun get-setf-expansion (place)
+ (if (symbolp place)
+ (let ((value (gensym)))
+ (values nil
+ nil
+ `(,value)
+ `(setq ,place ,value)
+ place))
+ (let* ((access-fn (car place))
+ (expander (cdr (assoc access-fn *setf-expanders*))))
+ (when (null expander)
+ (error "Unknown generalized reference."))
+ (apply expander (cdr place)))))
+
+ (defmacro define-setf-expander (access-fn lambda-list &body body)
+ (unless (symbolp access-fn)
+ (error "ACCESS-FN must be a symbol."))
+ `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
+ *setf-expanders*)
+ ',access-fn))
+
+ (defmacro setf (&rest pairs)
+ (cond
+ ((null pairs)
+ nil)
+ ((null (cdr pairs))
+ (error "Odd number of arguments to setf."))
+ ((null (cddr pairs))
+ (let ((place (first pairs))
+ (value (second pairs)))
+ (multiple-value-bind (vars vals store-vars writer-form reader-form)
+ (get-setf-expansion place)
+ ;; TODO: Optimize the expansion code here.
+ `(let* ,(mapcar #'list vars vals)
+ (multiple-value-bind ,store-vars
+ ,value
+ ,writer-form)))))
+ (t
+ `(progn
+ ,@(do ((pairs pairs (cddr pairs))
+ (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
+ ((null pairs)
+ (reverse result)))))))
+
+ (define-setf-expander car (x)
+ (let ((cons (gensym))
+ (new-value (gensym)))
+ (values (list cons)
+ (list x)
+ (list new-value)
+ `(progn (rplaca ,cons ,new-value) ,new-value)
+ `(car ,cons))))
+
+ (define-setf-expander cdr (x)
+ (let ((cons (gensym))
+ (new-value (gensym)))
+ (values (list cons)
+ (list x)
+ (list new-value)
+ `(progn (rplacd ,cons ,new-value) ,new-value)
+ `(car ,cons))))
+
+ ;;; Packages
(defvar *package-list* nil)
(unless (consp args)
(error "ARGS must be a non-empty list"))
(let ((counter 0)
- (variables '())
+ (fargs '())
(prelude ""))
(dolist (x args)
- (let ((v (code "x" (incf counter))))
- (push v variables)
- (concatf prelude
- (code "var " v " = " (ls-compile x) ";" *newline*
- "if (typeof " v " !== 'number') throw 'Not a number!';"
- *newline*))))
- (js!selfcall prelude (funcall function (reverse variables)))))
+ (if (numberp x)
+ (push (integer-to-string x) fargs)
+ (let ((v (code "x" (incf counter))))
+ (push v fargs)
+ (concatf prelude
+ (code "var " v " = " (ls-compile x) ";" *newline*
+ "if (typeof " v " !== 'number') throw 'Not a number!';"
+ *newline*)))))
+ (js!selfcall prelude (funcall function (reverse fargs)))))
(defmacro variable-arity (args &body body)
(error "Bad usage of VARIABLE-ARITY, you must pass a symbol"))
`(variable-arity-call ,args
(lambda (,args)
- (concat "return " ,@body ";" *newline*))))
+ (code "return " ,@body ";" *newline*))))
(defun num-op-num (x op y)
(type-check (("x" "number" x) ("y" "number" y))
package-name package-use-list packagep parse-integer plusp
prin1-to-string print proclaim prog1 prog2 progn psetq
push quote remove remove-if remove-if-not return
- return-from revappend reverse rplaca rplacd second set
+ return-from revappend reverse rplaca rplacd second set setf
setq some string-upcase string string= stringp subseq
symbol-function symbol-name symbol-package symbol-plist
symbol-value symbolp t tagbody third throw truncate unless
;; environment at this point of the compilation.
(eval-when-compile
(toplevel-compilation
+ (ls-compile `(setq *environment* ',*environment*))))
+
+ (eval-when-compile
+ (toplevel-compilation
(ls-compile
`(progn
,@(mapcar (lambda (s) `(%intern-symbol (js-vref ,(cdr s))))
*literal-symbols*)
(setq *literal-symbols* ',*literal-symbols*)
- (setq *environment* ',*environment*)
(setq *variable-counter* ,*variable-counter*)
(setq *gensym-counter* ,*gensym-counter*)
(setq *block-counter* ,*block-counter*)))))