X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fboot.lisp;h=ce61f98e2a3b54f21e2f8283543a8cd6eb68c865;hb=93a48dc177c1509396980002910124d70aaa4089;hp=845b601934a906b3211ccead09894f56f06718fc;hpb=c08b369e02f12e4a5c9fa79c7332dcdae24fd356;p=jscl.git

diff --git a/src/boot.lisp b/src/boot.lisp
index 845b601..ce61f98 100644
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -22,22 +22,23 @@
 ;;; Lisp world from scratch. This code has to define enough language
 ;;; to the compiler to be able to run.
 
-(eval-when-compile
-  (%compile-defmacro 'defmacro
-                     '(function
-                       (lambda (name args &rest body)
-                        `(eval-when-compile
-                           (%compile-defmacro ',name
-                                              '(function
-                                                (lambda ,(mapcar #'(lambda (x)
-                                                                     (if (eq x '&body)
-                                                                         '&rest
-                                                                         x))
-                                                                 args)
-                                                 ,@body))))))))
+(/debug "loading boot.lisp!")
+
+(eval-when (:compile-toplevel)
+  (let ((defmacro-macroexpander
+         '#'(lambda (form)
+              (destructuring-bind (name args &body body)
+                  form
+                (let ((whole (gensym)))
+                  `(eval-when (:compile-toplevel :execute)
+                     (%compile-defmacro ',name
+                                        '#'(lambda (,whole)
+                                             (destructuring-bind ,args ,whole
+                                               ,@body)))))))))
+    (%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)
@@ -45,12 +46,13 @@
      (declaim (special ,name))
      (declaim (constant ,name))
      (setq ,name ,value)
-     ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+     ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
      ',name))
 
 (defconstant t 't)
 (defconstant nil 'nil)
 (%js-vset "nil" nil)
+(%js-vset "t" t)
 
 (defmacro lambda (args &body body)
   `(function (lambda ,args ,@body)))
@@ -61,17 +63,17 @@
 (defmacro unless (condition &body body)
   `(if ,condition nil (progn ,@body)))
 
-(defmacro defvar (name value &optional docstring)
+(defmacro defvar (name &optional (value nil value-p) docstring)
   `(progn
      (declaim (special ,name))
-     (unless (boundp ',name) (setq ,name ,value))
-     ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+     ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
+     ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
      ',name))
 
 (defmacro defparameter (name value &optional docstring)
   `(progn
      (setq ,name ,value)
-     ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+     ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
      ',name))
 
 (defmacro defun (name args &rest body)
@@ -88,114 +90,90 @@
 (defvar *gensym-counter* 0)
 (defun gensym (&optional (prefix "G"))
   (setq *gensym-counter* (+ *gensym-counter* 1))
-  (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
+  (make-symbol (concat prefix (integer-to-string *gensym-counter*))))
 
 (defun boundp (x)
   (boundp x))
 
-;; Basic functions
-(defun = (x y) (= x y))
-(defun * (x y) (* x y))
-(defun / (x y) (/ x y))
-(defun 1+ (x) (+ x 1))
-(defun 1- (x) (- x 1))
-(defun zerop (x) (= x 0))
-
-(defun truncate (x &optional (y 1))
-  (floor (/ x y)))
+(defun fboundp (x)
+  (fboundp x))
 
+(defun eq (x y) (eq x y))
 (defun eql (x y) (eq x y))
 
 (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 dolist (iter &body body)
-  (let ((var (first iter))
-        (g!list (gensym)))
+(defmacro dolist ((var list &optional result) &body body)
+  (let ((g!list (gensym)))
+    (unless (symbolp var) (error "`~S' is not a symbol." var))
     `(block nil
-       (let ((,g!list ,(second iter))
+       (let ((,g!list ,list)
              (,var nil))
          (%while ,g!list
                  (setq ,var (car ,g!list))
                  (tagbody ,@body)
                  (setq ,g!list (cdr ,g!list)))
-         ,(third iter)))))
+         ,result))))
 
-(defmacro dotimes (iter &body body)
-  (let ((g!to (gensym))
-        (var (first iter))
-        (to (second iter))
-        (result (third iter)))
+(defmacro dotimes ((var count &optional result) &body body)
+  (let ((g!count (gensym)))
+    (unless (symbolp var) (error "`~S' is not a symbol." var))
     `(block nil
        (let ((,var 0)
-             (,g!to ,to))
-         (%while (< ,var ,g!to)
+             (,g!count ,count))
+         (%while (< ,var ,g!count)
                  (tagbody ,@body)
                  (incf ,var))
          ,result))))
 
 (defmacro cond (&rest clausules)
-  (if (null clausules)
-    nil
-    (if (eq (caar clausules) t)
-      `(progn ,@(cdar clausules))
-      (let ((test-symbol (gensym)))
-        `(let ((,test-symbol ,(caar clausules)))
-           (if ,test-symbol
-             ,(if (null (cdar clausules))
-                test-symbol
-                `(progn ,@(cdar clausules)))
-             (cond ,@(cdr clausules))))))))
+  (unless (null clausules)
+    (destructuring-bind (condition &body body)
+        (first clausules)
+      (cond
+        ((eq condition t)
+         `(progn ,@body))
+        ((null body)
+         (let ((test-symbol (gensym)))
+           `(let ((,test-symbol ,condition))
+              (if ,test-symbol
+                  ,test-symbol
+                  (cond ,@(rest clausules))))))
+        (t
+         `(if ,condition
+              (progn ,@body)
+              (cond ,@(rest clausules))))))))
 
 (defmacro case (form &rest clausules)
   (let ((!form (gensym)))
     `(let ((,!form ,form))
        (cond
          ,@(mapcar (lambda (clausule)
-                     (if (or (eq (car clausule) t)
-                             (eq (car clausule) 'otherwise))
-                         `(t ,@(cdr clausule))
-                         `((eql ,!form ',(car clausule))
-                           ,@(cdr clausule))))
+                     (destructuring-bind (keys &body body)
+                         clausule
+                       (if (or (eq keys 't) (eq keys 'otherwise))
+                           `(t nil ,@body)
+                           (let ((keys (if (listp keys) keys (list keys))))
+                             `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
+                               nil ,@body)))))
                    clausules)))))
 
 (defmacro ecase (form &rest clausules)
-  `(case ,form
-     ,@(append
-        clausules
-        `((t
-           (error "ECASE expression failed."))))))
+  (let ((g!form (gensym)))
+    `(let ((,g!form ,form))
+       (case ,g!form
+         ,@(append
+            clausules
+            `((t
+               (error "ECASE expression failed for the object `~S'." ,g!form))))))))
 
 (defmacro and (&rest forms)
   (cond
@@ -228,40 +206,12 @@
 (defmacro prog2 (form1 result &body body)
   `(prog1 (progn ,form1 ,result) ,@body))
 
-
-
-;;; Go on growing the Lisp language in Ecmalisp, with more high level
-;;; utilities as well as correct versions of other constructions.
-
-(defun + (&rest args)
-  (let ((r 0))
-    (dolist (x args r)
-      (incf r x))))
-
-(defun - (x &rest others)
-  (if (null others)
-      (- x)
-      (let ((r x))
-        (dolist (y others r)
-          (decf r y)))))
-
-(defun append-two (list1 list2)
-  (if (null list1)
-      list2
-      (cons (car list1)
-            (append (cdr list1) list2))))
-
-(defun append (&rest lists)
-  (!reduce #'append-two lists))
-
-(defun revappend (list1 list2)
-  (while list1
-    (push (car list1) list2)
-    (setq list1 (cdr list1)))
-  list2)
-
-(defun reverse (list)
-  (revappend list '()))
+(defmacro prog (inits &rest body )
+  (multiple-value-bind (forms decls docstring) (parse-body body)
+    `(block nil
+       (let ,inits
+         ,@decls
+         (tagbody ,@forms)))))
 
 (defmacro psetq (&rest pairs)
   (let (;; For each pair, we store here a list of the form
@@ -280,11 +230,13 @@
     (setq assignments (reverse assignments))
     ;;
     `(let ,(mapcar #'cdr assignments)
-       (setq ,@(!reduce #'append (mapcar #'butlast assignments))))))
+       (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
 
 (defmacro do (varlist endlist &body body)
   `(block nil
-     (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+     (let ,(mapcar (lambda (x) (if (symbolp x)
+                                   (list x nil)
+                                 (list (first x) (second x)))) varlist)
        (while t
          (when ,(car endlist)
            (return (progn ,@(cdr endlist))))
@@ -292,13 +244,16 @@
          (psetq
           ,@(apply #'append
                    (mapcar (lambda (v)
-                             (and (consp (cddr v))
+                             (and (listp v)
+                                  (consp (cddr v))
                                   (list (first v) (third v))))
                            varlist)))))))
 
 (defmacro do* (varlist endlist &body body)
   `(block nil
-     (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+     (let* ,(mapcar (lambda (x1) (if (symbolp x1)
+                                     (list x1 nil)
+                                   (list (first x1) (second x1)))) varlist)
        (while t
          (when ,(car endlist)
            (return (progn ,@(cdr endlist))))
@@ -306,29 +261,11 @@
          (setq
           ,@(apply #'append
                    (mapcar (lambda (v)
-                             (and (consp (cddr v))
+                             (and (listp v)
+                                  (consp (cddr v))
                                   (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))))
-
-(defun concat-two (s1 s2)
-  (concat-two s1 s2))
-
 (defmacro with-collect (&body body)
   (let ((head (gensym))
         (tail (gensym)))
@@ -347,6 +284,10 @@
 
 (defun identity (x) x)
 
+(defun complement (x)
+  (lambda (&rest args)
+    (not (apply x args))))
+
 (defun constantly (x)
   (lambda (&rest args)
     x))
@@ -360,50 +301,15 @@
 (defun char= (x y)
   (eql x y))
 
-(defun integerp (x)
-  (and (numberp x) (= (floor x) x)))
-
-(defun floatp (x)
-  (and (numberp x) (not (integerp x))))
-
-(defun plusp (x) (< 0 x))
-(defun minusp (x) (< x 0))
+(defun char< (x y)
+  (< (char-code x) (char-code y)))
 
 (defun atom (x)
   (not (consp x)))
 
-(defun find (item list &key key (test #'eql))
-  (dolist (x list)
-    (when (funcall test (funcall key x) item)
-      (return x))))
-
-(defun remove (x list)
-  (cond
-    ((null list)
-     nil)
-    ((eql x (car list))
-     (remove x (cdr list)))
-    (t
-     (cons (car list) (remove x (cdr list))))))
-
-(defun remove-if (func list)
-  (cond
-    ((null list)
-     nil)
-    ((funcall func (car list))
-     (remove-if func (cdr list)))
-    (t
-     ;;
-     (cons (car list) (remove-if func (cdr list))))))
-
-(defun remove-if-not (func list)
-  (cond
-    ((null list)
-     nil)
-    ((funcall func (car list))
-     (cons (car list) (remove-if-not func (cdr list))))
-    (t
-     (remove-if-not func (cdr list)))))
+(defun alpha-char-p (x)
+  (or (<= (char-code #\a) (char-code x) (char-code #\z))
+      (<= (char-code #\A) (char-code x) (char-code #\Z))))
 
 (defun digit-char-p (x)
   (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
@@ -414,58 +320,6 @@
   (and (<= 0 weight 9)
        (char "0123456789" weight)))
 
-(defun subseq (seq a &optional b)
-  (cond
-    ((stringp seq)
-     (if b
-         (slice seq a b)
-         (slice seq a)))
-    (t
-     (error "Unsupported argument."))))
-
-(defmacro do-sequence (iteration &body body)
-  (let ((seq (gensym))
-        (index (gensym)))
-    `(let ((,seq ,(second iteration)))
-       (cond
-         ;; Strings
-         ((stringp ,seq)
-          (let ((,index 0))
-            (dotimes (,index (length ,seq))
-              (let ((,(first iteration)
-                     (char ,seq ,index)))
-                ,@body))))
-         ;; Lists
-         ((listp ,seq)
-          (dolist (,(first iteration) ,seq)
-            ,@body))
-         (t
-          (error "type-error!"))))))
-
-(defun some (function seq)
-  (do-sequence (elt seq)
-    (when (funcall function elt)
-      (return-from some t))))
-
-(defun every (function seq)
-  (do-sequence (elt seq)
-    (unless (funcall function elt)
-      (return-from every nil)))
-  t)
-
-(defun position (elt sequence)
-  (let ((pos 0))
-    (do-sequence (x seq)
-      (when (eq elt x)
-        (return))
-      (incf pos))
-    pos))
-
-(defun string (x)
-  (cond ((stringp x) x)
-        ((symbolp x) (symbol-name x))
-        (t (char-to-string x))))
-
 (defun equal (x y)
   (cond
     ((eql x y) t)
@@ -473,19 +327,10 @@
      (and (consp y)
           (equal (car x) (car y))
           (equal (cdr x) (cdr y))))
-    ((arrayp x)
-     (and (arrayp y)
-          (let ((n (length x)))
-            (when (= (length y) n)
-              (dotimes (i n)
-                (unless (equal (aref x i) (aref y i))
-                  (return-from equal nil)))
-              t))))
+    ((stringp x)
+     (and (stringp y) (string= x y)))
     (t nil)))
 
-(defun string= (s1 s2)
-  (equal s1 s2))
-
 (defun fdefinition (x)
   (cond
     ((functionp x)
@@ -493,23 +338,12 @@
     ((symbolp x)
      (symbol-function x))
     (t
-     (error "Invalid function"))))
+     (error "Invalid function `~S'." x))))
 
 (defun disassemble (function)
   (write-line (lambda-code (fdefinition function)))
   nil)
 
-(defun documentation (x type)
-  "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
-  (ecase type
-    (function
-     (let ((func (fdefinition x)))
-       (oget func "docstring")))
-    (variable
-     (unless (symbolp x)
-       (error "Wrong argument type! it should be a symbol"))
-     (oget x "vardoc"))))
-
 (defmacro multiple-value-bind (variables value-from &body body)
   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
                           ,@body)
@@ -519,82 +353,45 @@
   `(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 (ls-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 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 (ls-macroexpand-1 (first pairs)))
-           (value (second pairs)))
-       (multiple-value-bind (vars vals store-vars writer-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)))))
-    (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)))
     `(let ((,value ,x))
        (cond
          ,@(mapcar (lambda (c)
-                     (if (eq (car c) t)
-                         `((t ,@(rest c)))
+                     (if (find (car c) '(t otherwise))
+                         `(t ,@(rest c))
                          `((,(ecase (car c)
                                     (integer 'integerp)
                                     (cons 'consp)
+                                    (list 'listp)
+                                    (vector 'vectorp)
+                                    (character 'characterp)
+                                    (sequence 'sequencep)
                                     (symbol 'symbolp)
+                                    (function 'functionp)
+                                    (float 'floatp)
                                     (array 'arrayp)
                                     (string 'stringp)
                                     (atom 'atom)
-                                    (null 'null))
+                                    (null 'null)
+                                    (package 'packagep))
                              ,value)
                            ,@(or (rest c)
                                  (list nil)))))
                    clausules)))))
 
+(defmacro etypecase (x &rest clausules)
+  (let ((g!x (gensym)))
+    `(let ((,g!x ,x))
+       (typecase ,g!x
+         ,@clausules
+         (t (error "~S fell through etypecase expression." ,g!x))))))
+
 (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))
@@ -605,11 +402,16 @@
 (defun get-universal-time ()
   (+ (get-unix-time) 2208988800))
 
-(defun concat (&rest strs)
-  (!reduce #'concat-two strs :initial-value ""))
-
 (defun values-list (list)
   (values-array (list-to-vector list)))
 
 (defun values (&rest args)
   (values-list args))
+
+(defun error (fmt &rest args)
+  (%throw (apply #'format nil fmt args)))
+
+(defmacro nth-value (n form)
+  `(multiple-value-call (lambda (&rest values)
+                          (nth ,n values))
+     ,form))