;;; Lisp world from scratch. This code has to define enough language
;;; to the compiler to be able to run.
-(eval-when-compile
+(/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
+ `(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)
(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))))
(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))))
(setq
,@(apply #'append
(mapcar (lambda (v)
- (and (consp (cddr v))
+ (and (listp v)
+ (consp (cddr v))
(list (first v) (third v))))
varlist)))))))
(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)
((null (cddr pairs))
(let ((place (!macroexpand-1 (first pairs)))
(value (second pairs)))
- (multiple-value-bind (vars vals store-vars writer-form)
+ (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)))))
+ ,writer-form
+ ,reader-form)))))
(t
`(progn
,@(do ((pairs pairs (cddr pairs))
`(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)))))
`(let ((,g!x ,x))
(typecase ,g!x
,@clausules
- (t (error "~X fell through etypeacase expression." ,g!x))))))
+ (t (error "~S fell through etypecase expression." ,g!x))))))
(defun notany (fn seq)
(not (some fn seq)))
(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))