X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fboot.lisp;h=4a435bd917405739bbaa8893f4359d8109596a12;hb=e8992591d4100811ac125bf97c5b153ddecb0250;hp=821c4825e424d62ef061be5c32e0bd1f74c59c43;hpb=b72391abab0319cf4abd2db441a47ea41ce93a67;p=jscl.git

diff --git a/src/boot.lisp b/src/boot.lisp
index 821c482..4a435bd 100644
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -52,6 +52,7 @@
 (defconstant t 't)
 (defconstant nil 'nil)
 (%js-vset "nil" nil)
+(%js-vset "t" t)
 
 (defmacro lambda (args &body body)
   `(function (lambda ,args ,@body)))
@@ -77,6 +78,8 @@
 
 (defmacro defun (name args &rest body)
   `(progn
+     (eval-when (:compile-toplevel)
+       (fn-info ',name :defined t))
      (fset ',name #'(named-lambda ,name ,args ,@body))
      ',name))
 
@@ -102,6 +105,12 @@
 
 (defun not (x) (if x nil t))
 
+(defun funcall (function &rest args)
+  (apply function args))
+
+(defun apply (function arg &rest args)
+  (apply function (apply #'list* arg args)))
+
 ;; Basic macros
 
 (defmacro dolist ((var list &optional result) &body body)
@@ -346,117 +355,6 @@
   `(multiple-value-call #'list ,value-from))
 
 
-;;; Generalized references (SETF)
-
-(eval-when(:compile-toplevel :load-toplevel :execute)
-  (defvar *setf-expanders* nil)
-  (defun !get-setf-expansion (place)
-    (if (symbolp place)
-        (let ((value (gensym)))
-          (values nil
-                  nil
-                  `(,value)
-                  `(setq ,place ,value)
-                  place))
-        (let ((place (!macroexpand-1 place)))
-          (let* ((access-fn (car place))
-                 (expander (cdr (assoc access-fn *setf-expanders*))))
-            (when (null expander)
-              (error "Unknown generalized reference."))
-            (apply expander (cdr place)))))))
-(fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
-
-(defmacro define-setf-expander (access-fn lambda-list &body body)
-  (unless (symbolp access-fn)
-    (error "ACCESS-FN `~S' must be a symbol." access-fn))
-  `(eval-when (:compile-toplevel :load-toplevel :execute)
-     (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 (!macroexpand-1 (first pairs)))
-           (value (second pairs)))
-       (multiple-value-bind (vars vals store-vars writer-form reader-form)
-           (!get-setf-expansion place)
-         ;; TODO: Optimize the expansion a little bit to avoid let*
-         ;; or multiple-value-bind when unnecesary.
-         `(let* ,(mapcar #'list vars vals)
-            (multiple-value-bind ,store-vars
-                ,value
-              ,writer-form
-              ,reader-form)))))
-    (t
-     `(progn
-        ,@(do ((pairs pairs (cddr pairs))
-               (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
-              ((null pairs)
-               (reverse result)))))))
-
-(defmacro incf (place &optional (delta 1))
-  (multiple-value-bind (dummies vals newval setter getter)
-      (!get-setf-expansion place)
-    (let ((d (gensym)))
-      `(let* (,@(mapcar #'list dummies vals)
-              (,d ,delta)
-                (,(car newval) (+ ,getter ,d))
-                ,@(cdr newval))
-         ,setter))))
-
-(defmacro decf (place &optional (delta 1))
-  (multiple-value-bind (dummies vals newval setter getter)
-      (!get-setf-expansion place)
-    (let ((d (gensym)))
-      `(let* (,@(mapcar #'list dummies vals)
-              (,d ,delta)
-              (,(car newval) (- ,getter ,d))
-              ,@(cdr newval))
-         ,setter))))
-
-(defmacro push (x place)
-  (multiple-value-bind (dummies vals newval setter getter)
-      (!get-setf-expansion place)
-    (let ((g (gensym)))
-      `(let* ((,g ,x)
-              ,@(mapcar #'list dummies vals)
-              (,(car newval) (cons ,g ,getter))
-              ,@(cdr newval))
-         ,setter))))
-
-(defmacro pop (place)
-  (multiple-value-bind (dummies vals newval setter getter)
-    (!get-setf-expansion place)
-    (let ((head (gensym)))
-      `(let* (,@(mapcar #'list dummies vals)
-              (,head ,getter)
-              (,(car newval) (cdr ,head))
-              ,@(cdr newval))
-         ,setter
-         (car ,head)))))
-
-(defmacro pushnew (x place &rest keys &key key test test-not)
-  (declare (ignore key test test-not))
-  (multiple-value-bind (dummies vals newval setter getter)
-      (!get-setf-expansion place)
-    (let ((g (gensym))
-          (v (gensym)))
-      `(let* ((,g ,x)
-              ,@(mapcar #'list dummies vals)
-              ,@(cdr newval)
-              (,v ,getter))
-         (if (member ,g ,v ,@keys)
-             ,v
-             (let ((,(car newval) (cons ,g ,getter)))
-               ,setter))))))
-
-
-
 ;; Incorrect typecase, but used in NCONC.
 (defmacro typecase (x &rest clausules)
   (let ((value (gensym)))