`(setq ,x (- ,x ,delta)))
(defmacro push (x place)
- `(setq ,place (cons ,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 dolist (iter &body body)
(let ((var (first iter))
((funcall func (car list))
(remove-if func (cdr list)))
(t
+ ;;
(cons (car list) (remove-if func (cdr list))))))
(defun remove-if-not (func list)
(t
(error "Unsupported argument."))))
+ (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 some (function seq)
- (cond
- ((stringp seq)
- (let ((index 0)
- (size (length seq)))
- (while (< index size)
- (when (funcall function (char seq index))
- (return-from some t))
- (incf index))
- nil))
- ((listp seq)
- (dolist (x seq nil)
- (when (funcall function x)
- (return t))))
- (t
- (error "Unknown sequence."))))
+ (do-sequence (elt seq)
+ (when (funcall function elt)
+ (return-from some t))))
(defun every (function seq)
- (cond
- ((stringp seq)
- (let ((index 0)
- (size (length seq)))
- (while (< index size)
- (unless (funcall function (char seq index))
- (return-from every nil))
- (incf index))
- t))
- ((listp seq)
- (dolist (x seq t)
- (unless (funcall function x)
- (return))))
- (t
- (error "Unknown sequence."))))
+ (do-sequence (elt seq)
+ (unless (funcall function elt)
+ (return-from every nil)))
+ t)
(defun assoc (x alist)
(while alist
`(progn (rplacd ,cons ,new-value) ,new-value)
`(car ,cons))))
-<<<<<<< HEAD
- (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))))
-=======
;; Incorrect typecase, but used in NCONC.
(defmacro typecase (x &rest clausules)
(let ((value (gensym)))
(defun nreconc (x y)
(do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
- (2nd x 1st) ; 2nd follows first down the list.
- (3rd y 2nd)) ;3rd follows 2nd down the list.
+ (2nd x 1st) ; 2nd follows first down the list.
+ (3rd y 2nd)) ;3rd follows 2nd down the list.
((atom 2nd) 3rd)
(rplacd 2nd 3rd)))
(defun notany (fn seq)
(not (some fn seq)))
->>>>>>> backquote
;; Packages
(concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
")"))
((arrayp form)
- (concat "#" (prin1-to-string (vector-to-list form))))
+ (concat "#" (if (zerop (length form))
+ "()"
+ (prin1-to-string (vector-to-list form)))))
((packagep form)
(concat "#<PACKAGE " (package-name form) ">"))))