(unless key (setf key (gensym "KEY")) (push key ignores))
(unless value (setf value (gensym "VALUE")) (push value ignores))
`(block nil
- (mapaa (lambda (,key ,value)
+ (mapaa (lambda (,key ,value)
,@decls
,@(and ignores `((declare (ignore ,@ignores))))
(tagbody ,@body))
- ,tree)
- ,result))))
+ ,tree)
+ ,result))))
;;;--------------------------------------------------------------------------
;;; Testing.
(defun make-heap
(&key (compare #'<=) (key #'identity)
- (type 't) (init-size 16) (contents nil contentsp))
+ (type 't) (init-size 16) (contents nil contentsp))
"Return a new heap.
COMPARE is a partial-order predicate: (COMPARE X Y) should return true if
the value stack."
`(progn
(setf (get ',op ',kind)
- (lambda () ,@body))
+ (lambda () ,@body))
',op))
(defmacro definfix (op prec &body body)
(let ((stuff nil))
(loop
(unless (symbolp *token*)
- (error "expected symbol; found ~S" *token*))
+ (error "expected symbol; found ~S" *token*))
(push *token* stuff)
(get-token)
(unless (delim '|,| nil)
(defun foo (x) (- x 6)))
("bind x = 3 in x - 2" . (let ((x 3)) (- x 2)))
("bind x, y = values(1, 2),
- z = 3,
- docs, decls, body = parse-body(body) in complicated" .
+ z = 3,
+ docs, decls, body = parse-body(body) in complicated" .
(multiple-value-bind (x y) (values 1 2)
(let ((z 3))
(multiple-value-bind (docs decls body) (parse-body body)
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
- (listify syms)))
+ (listify syms)))
,@body))
(defmacro let*/gensyms (binds &body body)
each VAR is bound to a gensym, and in the final expansion, each of those
gensyms will be bound to the corresponding VALUE."
(labels ((more (binds)
- (let ((tmp (gensym "TMP")) (bind (car binds)))
- `((let ((,tmp ,(cadr bind))
- (,(car bind) (gensym ,(symbol-name (car bind)))))
- `(let ((,,(car bind) ,,tmp))
- ,,@(if (cdr binds)
- (more (cdr binds))
- body)))))))
+ (let ((tmp (gensym "TMP")) (bind (car binds)))
+ `((let ((,tmp ,(cadr bind))
+ (,(car bind) (gensym ,(symbol-name (car bind)))))
+ `(let ((,,(car bind) ,,tmp))
+ ,,@(if (cdr binds)
+ (more (cdr binds))
+ body)))))))
(if (null binds)
- `(progn ,@body)
- (car (more (mapcar #'pairify (listify binds)))))))
+ `(progn ,@body)
+ (car (more (mapcar #'pairify (listify binds)))))))
;;;--------------------------------------------------------------------------
;;; Some simple yet useful control structures.
collect val into vals
finally (return (values vars vals)))
`(labels ((,name ,vars
- ,@body))
+ ,@body))
(,name ,@vals))))
(defmacro while (cond &body body)
(list `(let ((,(or vary varx) ,argument)
,@(and vary
`((,varx ,scrutinee))))
- ,@forms))
+ ,@forms))
forms))))
clauses)))))
(if (null places)
`(progn ,@body)
(let*/gensyms (environment)
- (labels
- ((more (places)
- (let ((place (car places)))
- (with-gensyms (tmp valtmps valforms
- newtmps setform getform)
- `((let ((,tmp ,(cadr place))
- (,(car place)
- (gensym ,(symbol-name (car place)))))
- (multiple-value-bind
- (,valtmps ,valforms
- ,newtmps ,setform ,getform)
- (get-setf-expansion ,tmp
- ,environment)
- (list 'let*
- (mapcar #'list ,valtmps ,valforms)
- `(symbol-macrolet ((,,(car place)
- (%place-ref ,,getform
- ,,setform
- ,,newtmps)))
- ,,@(if (cdr places)
- (more (cdr places))
- body))))))))))
- (car (more (mapcar #'pairify (listify places))))))))
+ (labels
+ ((more (places)
+ (let ((place (car places)))
+ (with-gensyms (tmp valtmps valforms
+ newtmps setform getform)
+ `((let ((,tmp ,(cadr place))
+ (,(car place)
+ (gensym ,(symbol-name (car place)))))
+ (multiple-value-bind
+ (,valtmps ,valforms
+ ,newtmps ,setform ,getform)
+ (get-setf-expansion ,tmp
+ ,environment)
+ (list 'let*
+ (mapcar #'list ,valtmps ,valforms)
+ `(symbol-macrolet ((,,(car place)
+ (%place-ref ,,getform
+ ,,setform
+ ,,newtmps)))
+ ,,@(if (cdr places)
+ (more (cdr places))
+ body))))))))))
+ (car (more (mapcar #'pairify (listify places))))))))
;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.
(get-setf-expansion place env)
`(let* (,@(mapcar #'list valtmps valforms))
(make-loc (lambda () ,getform)
- (lambda (,@newtmps) ,setform)))))
+ (lambda (,@newtmps) ,setform)))))
(declaim (inline loc (setf loc)))
(defun print-object-with-slots (obj stream)
"Prints objects in a pleasant way. Not too clever about circularity."
(let ((class (class-of obj))
- (magic (cons 'magic nil)))
+ (magic (cons 'magic nil)))
(print-unreadable-object (obj stream)
(pprint-logical-block
- (stream
- (mapcan (lambda (slot)
- (list (or (car (slot-definition-initargs slot))
- (slot-definition-name slot))
- (if (slot-boundp-using-class class obj slot)
- (slot-value-using-class class obj slot)
- magic)))
- (class-slots class)))
- (format stream "~S" (class-name class))
- (let ((sep nil))
- (loop
- (pprint-exit-if-list-exhausted)
- (if sep
- (format stream " ~_")
- (progn (format stream " ~@_~:I") (setf sep t)))
- (let ((name (pprint-pop))
- (value (pprint-pop)))
- (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
- name (eq value magic) value))))))))
+ (stream
+ (mapcan (lambda (slot)
+ (list (or (car (slot-definition-initargs slot))
+ (slot-definition-name slot))
+ (if (slot-boundp-using-class class obj slot)
+ (slot-value-using-class class obj slot)
+ magic)))
+ (class-slots class)))
+ (format stream "~S" (class-name class))
+ (let ((sep nil))
+ (loop
+ (pprint-exit-if-list-exhausted)
+ (if sep
+ (format stream " ~_")
+ (progn (format stream " ~@_~:I") (setf sep t)))
+ (let ((name (pprint-pop))
+ (value (pprint-pop)))
+ (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
+ name (eq value magic) value))))))))
;;;----- That's all, folks --------------------------------------------------
(progn ,@body)
(simple-condition (,cond)
(apply #'die
- (simple-condition-format-control ,cond)
- (simple-condition-format-arguments ,cond)))
+ (simple-condition-format-control ,cond)
+ (simple-condition-format-arguments ,cond)))
(error (,cond)
(die "~A" ,cond)))))
(with-output-to-string (s)
(when strs
(loop
- (princ (stringify (pop strs)) s)
+ (princ (stringify (pop strs)) s)
(unless strs
(return))
(princ del s)))))
#+sbcl sb-ext:*posix-argv*
#+ecl (loop from i below (ext:argc) collect (ext:argv i))
#+clisp (loop with argv = (ext:argv)
- for i from 7 below (length argv)
+ for i from 7 below (length argv)
collect (aref argv i))
'("<unknown-lisp>" "--" "<unknown-script>")))
(setf *program-name* (pathname-name (car *command-line*))))
`(defstruct (stat (:predicate statp)
(:conc-name st-)
(:constructor %make-stat-boa ,slots))
- ,doc
- ,@slots)))
+ ,doc
+ ,@slots)))
(doit
"Structure representing all the useful information `stat' returns about a
file."
to
(logior unix:O_WRONLY unix:O_CREAT how)
(logand (st-mode st) #o777))
- (sys-fchmod out (st-mode st))
+ (sys-fchmod out (st-mode st))
(sys-utimes to (st-atime st) 0 (st-mtime st) 0)
(with-errno-handlers ()
(sys-fchown out (st-uid st) (st-gid st))
~mdw / lisp / commitdiff