X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fboot.lisp;h=4a435bd917405739bbaa8893f4359d8109596a12;hb=e1301bcded5eed2d9259d7688edf03892468fe2b;hp=3541b23a863e800e602dc220d4542eb2eba185b3;hpb=5b3421abce6203fd73ac298f1fbba783abaeab5f;p=jscl.git diff --git a/src/boot.lisp b/src/boot.lisp index 3541b23..4a435bd 100644 --- a/src/boot.lisp +++ b/src/boot.lisp @@ -24,13 +24,13 @@ (/debug "loading boot.lisp!") -(eval-when-compile +(eval-when (:compile-toplevel) (let ((defmacro-macroexpander '#'(lambda (form) (destructuring-bind (name args &body body) form (let ((whole (gensym))) - `(eval-when-compile + `(eval-when (:compile-toplevel :execute) (%compile-defmacro ',name '#'(lambda (,whole) (destructuring-bind ,args ,whole @@ -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))) @@ -419,17 +346,6 @@ (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 "The type of documentation `~S' is not a symbol." type)) - (oget x "vardoc")))) - (defmacro multiple-value-bind (variables value-from &body body) `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym)) ,@body) @@ -439,75 +355,29 @@ `(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))) `(let ((,value ,x)) (cond ,@(mapcar (lambda (c) - (if (eq (car c) t) + (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))))) @@ -518,12 +388,12 @@ `(let ((,g!x ,x)) (typecase ,g!x ,@clausules - (t (error "~X fell through etypecase expression." ,g!x)))))) + (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))