(/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
(%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)
(defun not (x) (if x nil t))
;; 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)))
,@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).
(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)))
(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)
;;; 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))))))
+(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))
- `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
- *setf-expanders*)
- ',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
(let ((place (!macroexpand-1 (first pairs)))
(value (second pairs)))
(multiple-value-bind (vars vals store-vars writer-form reader-form)
- (get-setf-expansion place)
+ (!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)
((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)))
`(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)
(array 'arrayp)
(string 'stringp)
(atom 'atom)
- (null 'null))
+ (null 'null)
+ (package 'packagep))
,value)
,@(or (rest c)
(list nil)))))
(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))
projects / jscl.git / blobdiff