;;; Lisp world from scratch. This code has to define enough language
;;; to the compiler to be able to run.
+(/debug "loading boot.lisp!")
+
(eval-when-compile
(let ((defmacro-macroexpander
'#'(lambda (form)
(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)
`(progn
(declaim (special ,name))
,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
- ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+ ,@(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)
(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))
;; Basic macros
-
(defmacro incf (place &optional (delta 1))
(multiple-value-bind (dummies vals newval setter getter)
(get-setf-expansion place)
,@(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)))
(unless (symbolp var) (error "`~S' is not a symbol." var))
;;; 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
(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)))))))
((listp seq)
(list-length seq))))
-(defun concat-two (s1 s2)
- (concat-two s1 s2))
-
(defmacro with-collect (&body body)
(let ((head (gensym))
(tail (gensym)))
(defun identity (x) x)
+(defun complement (x)
+ (lambda (&rest args)
+ (not (apply x args))))
+
(defun constantly (x)
(lambda (&rest args)
x))
(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 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 #\Z) (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)))
(and (<= 0 weight 9)
(char "0123456789" weight)))
-(defun subseq (seq a &optional b)
- (if b
- (slice seq a b)
- (slice seq a)))
-
-(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 find (item sequence &key (key #'identity) (test #'eql))
- (do-sequence (x sequence)
- (when (funcall test (funcall key x) item)
- (return x))))
-
-(defun find-if (predicate sequence &key (key #'identity))
- (do-sequence (x sequence)
- (when (funcall predicate (funcall key x))
- (return x))))
-
-(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 equal (x y)
(cond
((eql x y) t)
((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))
(cond
,@(mapcar (lambda (c)
(if (eq (car c) t)
- `((t ,@(rest c)))
+ `(t ,@(rest c))
`((,(ecase (car c)
(integer 'integerp)
(cons 'consp)
+ (list 'listp)
+ (sequence 'sequencep)
(symbol 'symbolp)
+ (function 'functionp)
+ (float 'floatp)
(array 'arrayp)
(string 'stringp)
(atom 'atom)
`(let ((,g!x ,x))
(typecase ,g!x
,@clausules
- (t (error "~X fell through etypeacase expression." ,g!x))))))
+ (t (error "~X fell through etypecase expression." ,g!x))))))
(defun notany (fn seq)
(not (some fn seq)))
(defun get-universal-time ()
(+ (get-unix-time) 2208988800))
-(defun concat (&rest strs)
- (!reduce #'concat-two strs ""))
-
(defun values-list (list)
(values-array (list-to-vector list)))
(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