;;; to the compiler to be able to run.
(eval-when-compile
- (%compile-defmacro 'defmacro
- '(function
- (lambda (name args &rest body)
- `(eval-when-compile
- (%compile-defmacro ',name
- '(function
- (lambda ,(mapcar #'(lambda (x)
- (if (eq x '&body)
- '&rest
- x))
- args)
- ,@body))))))))
+ (let ((defmacro-macroexpander
+ '#'(lambda (form)
+ (destructuring-bind (name args &body body)
+ form
+ (let ((whole (gensym)))
+ `(eval-when-compile
+ (%compile-defmacro ',name
+ '#'(lambda (,whole)
+ (destructuring-bind ,args ,whole
+ ,@body)))))))))
+ (%compile-defmacro 'defmacro defmacro-macroexpander)))
(defmacro declaim (&rest decls)
`(eval-when-compile
(defmacro unless (condition &body body)
`(if ,condition nil (progn ,@body)))
-(defmacro defvar (name value &optional docstring)
+(defmacro defvar (name &optional (value nil value-p) docstring)
`(progn
(declaim (special ,name))
- (unless (boundp ',name) (setq ,name ,value))
+ ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
',name))
,@(cdr newval))
,setter))))
-(defmacro dolist (iter &body body)
- (let ((var (first iter))
- (g!list (gensym)))
+(defmacro dolist ((var list &optional result) &body body)
+ (let ((g!list (gensym)))
+ (unless (symbolp var) (error "`~S' is not a symbol." var))
`(block nil
- (let ((,g!list ,(second iter))
+ (let ((,g!list ,list)
(,var nil))
(%while ,g!list
(setq ,var (car ,g!list))
(tagbody ,@body)
(setq ,g!list (cdr ,g!list)))
- ,(third iter)))))
+ ,result))))
-(defmacro dotimes (iter &body body)
- (let ((g!to (gensym))
- (var (first iter))
- (to (second iter))
- (result (third iter)))
+(defmacro dotimes ((var count &optional result) &body body)
+ (let ((g!count (gensym)))
+ (unless (symbolp var) (error "`~S' is not a symbol." var))
`(block nil
(let ((,var 0)
- (,g!to ,to))
- (%while (< ,var ,g!to)
+ (,g!count ,count))
+ (%while (< ,var ,g!count)
(tagbody ,@body)
(incf ,var))
,result))))
(defmacro cond (&rest clausules)
- (if (null clausules)
- nil
- (if (eq (caar clausules) t)
- `(progn ,@(cdar clausules))
- (let ((test-symbol (gensym)))
- `(let ((,test-symbol ,(caar clausules)))
- (if ,test-symbol
- ,(if (null (cdar clausules))
- test-symbol
- `(progn ,@(cdar clausules)))
- (cond ,@(cdr clausules))))))))
+ (unless (null clausules)
+ (destructuring-bind (condition &body body)
+ (first clausules)
+ (cond
+ ((eq condition t)
+ `(progn ,@body))
+ ((null body)
+ (let ((test-symbol (gensym)))
+ `(let ((,test-symbol ,condition))
+ (if ,test-symbol
+ ,test-symbol
+ (cond ,@(rest clausules))))))
+ (t
+ `(if ,condition
+ (progn ,@body)
+ (cond ,@(rest clausules))))))))
(defmacro case (form &rest clausules)
(let ((!form (gensym)))
`(let ((,!form ,form))
(cond
,@(mapcar (lambda (clausule)
- (if (or (eq (car clausule) t)
- (eq (car clausule) 'otherwise))
- `(t ,@(cdr clausule))
- `((eql ,!form ',(car clausule))
- ,@(cdr clausule))))
+ (destructuring-bind (keys &body body)
+ clausule
+ (if (or (eq keys 't) (eq keys 'otherwise))
+ `(t nil ,@body)
+ (let ((keys (if (listp keys) keys (list keys))))
+ `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
+ nil ,@body)))))
clausules)))))
(defmacro ecase (form &rest clausules)
(defmacro prog2 (form1 result &body body)
`(prog1 (progn ,form1 ,result) ,@body))
+(defmacro prog (inits &rest body )
+ (multiple-value-bind (forms decls docstring) (parse-body body)
+ `(block nil
+ (let ,inits
+ ,@decls
+ (tagbody ,@forms)))))
;;; Go on growing the Lisp language in Ecmalisp, with more high level
(append (cdr list1) list2))))
(defun append (&rest lists)
- (!reduce #'append-two lists))
+ (!reduce #'append-two lists nil))
(defun revappend (list1 list2)
(while list1
(setq assignments (reverse assignments))
;;
`(let ,(mapcar #'cdr assignments)
- (setq ,@(!reduce #'append (mapcar #'butlast assignments))))))
+ (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
(defmacro do (varlist endlist &body body)
`(block nil
(defun atom (x)
(not (consp x)))
-(defun find (item list &key key (test #'eql))
- (dolist (x list)
- (when (funcall test (funcall key x) item)
- (return x))))
-
-(defun remove (x list)
+(defmacro doseq ((elt seq &optional index) &body body)
+ (let* ((nseq (gensym "seq"))
+ (i (or index (gensym "i")))
+ (list-body (if index
+ `(let ((,i -1))
+ (dolist (,elt ,nseq)
+ (incf ,i)
+ ,@body))
+ `(dolist (,elt ,nseq)
+ ,@body))))
+ `(let ((,nseq ,seq))
+ (if (listp ,nseq)
+ ,list-body
+ (dotimes (,i (length ,nseq))
+ (let ((,elt (aref ,nseq ,i)))
+ ,@body))))))
+
+(defun find (item seq &key key (test #'eql))
+ (if key
+ (doseq (x seq)
+ (when (funcall test (funcall key x) item)
+ (return x)))
+ (doseq (x seq)
+ (when (funcall test x item)
+ (return x)))))
+
+(defun remove (x seq)
(cond
- ((null list)
+ ((null seq)
nil)
- ((eql x (car list))
- (remove x (cdr list)))
+ ((listp seq)
+ (let* ((head (cons nil nil))
+ (tail head))
+ (doseq (elt seq)
+ (unless (eql x elt)
+ (let ((new (list elt)))
+ (rplacd tail new)
+ (setq tail new))))
+ (cdr head)))
(t
- (cons (car list) (remove x (cdr list))))))
+ (let (vector)
+ (doseq (elt seq index)
+ (if (eql x elt)
+ ;; Copy the beginning of the vector only when we find an element
+ ;; that does not match.
+ (unless vector
+ (setq vector (make-array 0))
+ (dotimes (i index)
+ (vector-push-extend (aref seq i) vector)))
+ (when vector
+ (vector-push-extend elt vector))))
+ (or vector seq)))))
(defun remove-if (func list)
(cond
(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))))
+
(defun digit-char-p (x)
(if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
(- (char-code x) (char-code #\0))
(char "0123456789" weight)))
(defun subseq (seq a &optional b)
- (cond
- ((stringp seq)
- (if b
- (slice seq a b)
- (slice seq a)))
- (t
- (error "Unsupported argument."))))
+ (if b
+ (slice seq a b)
+ (slice seq a)))
(defmacro do-sequence (iteration &body body)
(let ((seq (gensym))
(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)
(incf pos))
pos))
-(defun string (x)
- (cond ((stringp x) x)
- ((symbolp x) (symbol-name x))
- (t (char-to-string x))))
-
(defun equal (x y)
(cond
((eql x y) t)
(and (consp y)
(equal (car x) (car y))
(equal (cdr x) (cdr y))))
- ((arrayp x)
- (and (arrayp y)
- (let ((n (length x)))
- (when (= (length y) n)
- (dotimes (i n)
- (unless (equal (aref x i) (aref y i))
- (return-from equal nil)))
- t))))
+ ((stringp x)
+ (and (stringp y) (string= x y)))
(t nil)))
-(defun string= (s1 s2)
- (equal s1 s2))
-
(defun fdefinition (x)
(cond
((functionp x)
`(,value)
`(setq ,place ,value)
place))
- (let ((place (ls-macroexpand-1 place)))
+ (let ((place (!macroexpand-1 place)))
(let* ((access-fn (car place))
(expander (cdr (assoc access-fn *setf-expanders*))))
(when (null expander)
((null (cdr pairs))
(error "Odd number of arguments to setf."))
((null (cddr pairs))
- (let ((place (ls-macroexpand-1 (first pairs)))
+ (let ((place (!macroexpand-1 (first pairs)))
(value (second pairs)))
(multiple-value-bind (vars vals store-vars writer-form)
(get-setf-expansion place)
(list nil)))))
clausules)))))
+(defmacro etypecase (x &rest clausules)
+ (let ((g!x (gensym)))
+ `(let ((,g!x ,x))
+ (typecase ,g!x
+ ,@clausules
+ (t (error "~X fell through etypeacase expression." ,g!x))))))
+
(defun notany (fn seq)
(not (some fn seq)))
-
(defconstant internal-time-units-per-second 1000)
(defun get-internal-real-time ()
(+ (get-unix-time) 2208988800))
(defun concat (&rest strs)
- (!reduce #'concat-two strs :initial-value ""))
+ (!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)))
+