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

diff --git a/src/boot.lisp b/src/boot.lisp
index 4dead5c..4a435bd 100644
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -38,7 +38,7 @@
     (%compile-defmacro 'defmacro defmacro-macroexpander)))
 
 (defmacro declaim (&rest decls)
-  `(eval-when-compile
+  `(eval-when (:compile-toplevel :execute)
      ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
 
 (defmacro defconstant (name value &optional docstring)
@@ -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,51 +105,13 @@
 
 (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 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 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))))))
 
 (defmacro dolist ((var list &optional result) &body body)
   (let ((g!list (gensym)))
@@ -250,28 +215,6 @@
          ,@decls
          (tagbody ,@forms)))))
 
-
-;;; Go on growing the Lisp language in Ecmalisp, with more high level
-;;; utilities as well as correct versions of other constructions.
-
-(defun append-two (list1 list2)
-  (if (null list1)
-      list2
-      (cons (car list1)
-            (append (cdr list1) list2))))
-
-(defun append (&rest lists)
-  (!reduce #'append-two lists nil))
-
-(defun revappend (list1 list2)
-  (while list1
-    (push (car list1) list2)
-    (setq list1 (cdr list1)))
-  list2)
-
-(defun reverse (list)
-  (revappend list '()))
-
 (defmacro psetq (&rest pairs)
   (let (;; For each pair, we store here a list of the form
         ;; (VARIABLE GENSYM VALUE).
@@ -325,22 +268,6 @@
                                   (list (first v) (third v))))
                            varlist)))))))
 
-(defun list-length (list)
-  (let ((l 0))
-    (while (not (null list))
-      (incf l)
-      (setq list (cdr list)))
-    l))
-
-(defun length (seq)
-  (cond
-    ((stringp seq)
-     (string-length seq))
-    ((arrayp seq)
-     (oget seq "length"))
-    ((listp seq)
-     (list-length seq))))
-
 (defmacro with-collect (&body body)
   (let ((head (gensym))
         (tail (gensym)))
@@ -428,57 +355,6 @@
   `(multiple-value-call #'list ,value-from))
 
 
-;;; 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 ((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))))))
-
-(defmacro define-setf-expander (access-fn lambda-list &body body)
-  (unless (symbolp access-fn)
-    (error "ACCESS-FN `~S' must be a symbol." access-fn))
-  `(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 (!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)))))))
-
 ;; Incorrect typecase, but used in NCONC.
 (defmacro typecase (x &rest clausules)
   (let ((value (gensym)))
@@ -517,7 +393,7 @@
 (defun notany (fn seq)
   (not (some fn seq)))
 
-(defconstant internal-time-units-per-second 1000) 
+(defconstant internal-time-units-per-second 1000)
 
 (defun get-internal-real-time ()
   (get-internal-real-time))