(/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)
(defconstant t 't)
(defconstant nil 'nil)
(%js-vset "nil" nil)
+(%js-vset "t" t)
(defmacro lambda (args &body body)
`(function (lambda ,args ,@body)))
(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)))
,@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)
`(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)))))
`(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))
(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))
projects / jscl.git / blobdiff