From e8abb2862e1a3b5f5a296d4fc00fe1b8e3200b4b Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 30 Aug 2015 10:58:38 +0100 Subject: [PATCH] src/utilities.lisp, src/optparse.lisp: Move locatives to `utilities'. --- src/optparse.lisp | 60 ------------------------------------------------------ src/utilities.lisp | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 60 insertions(+), 60 deletions(-) diff --git a/src/optparse.lisp b/src/optparse.lisp index 70bb012..a2ac290 100644 --- a/src/optparse.lisp +++ b/src/optparse.lisp @@ -113,66 +113,6 @@ (do-case2-like 'ecase vform clauses)) ;;;-------------------------------------------------------------------------- -;;; Locatives. - -(export '(loc locp)) -(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) - "Locative data type. See `locf' and `ref'." - (reader nil :type function) - (writer nil :type function)) - -(export 'locf) -(defmacro locf (place &environment env) - "Slightly cheesy locatives. - - (locf PLACE) returns an object which, using the `ref' function, can be - used to read or set the value of PLACE. It's cheesy because it uses - closures rather than actually taking the address of something. Also, - unlike Zetalisp, we don't overload `car' to do our dirty work." - (multiple-value-bind - (valtmps valforms newtmps setform getform) - (get-setf-expansion place env) - `(let* (,@(mapcar #'list valtmps valforms)) - (make-loc (lambda () ,getform) - (lambda (,@newtmps) ,setform))))) - -(export 'ref) -(declaim (inline ref (setf ref))) -(defun ref (loc) - "Fetch the value referred to by a locative." - (funcall (loc-reader loc))) -(defun (setf ref) (new loc) - "Store a new value in the place referred to by a locative." - (funcall (loc-writer loc) new)) - -(export 'with-locatives) -(defmacro with-locatives (locs &body body) - "Evaluate BODY with implicit locatives. - - LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a - symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it - defaults to SYM. As an abbreviation for a common case, LOCS may be a - symbol instead of a list. - - The BODY is evaluated in an environment where each SYM is a symbol macro - which expands to (ref LOC-EXPR) -- or, in fact, something similar which - doesn't break if LOC-EXPR has side-effects. Thus, references, including - `setf' forms, fetch or modify the thing referred to by the LOC-EXPR. - Useful for covering over where something uses a locative." - (setf locs (mapcar (lambda (item) - (cond ((atom item) (list item item)) - ((null (cdr item)) (list (car item) (car item))) - (t item))) - (if (listp locs) locs (list locs)))) - (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) - (ll (mapcar #'cadr locs)) - (ss (mapcar #'car locs))) - `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) - (symbol-macrolet (,@(mapcar (lambda (sym tmp) - `(,sym (ref ,tmp))) ss tt)) - ,@body)))) - -;;;-------------------------------------------------------------------------- ;;; Standard error-reporting functions. (export 'moan) diff --git a/src/utilities.lisp b/src/utilities.lisp index 1093f68..d1755da 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -195,6 +195,66 @@ body))) ;;;-------------------------------------------------------------------------- +;;; Locatives. + +(export '(loc locp)) +(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) + "Locative data type. See `locf' and `ref'." + (reader nil :type function) + (writer nil :type function)) + +(export 'locf) +(defmacro locf (place &environment env) + "Slightly cheesy locatives. + + (locf PLACE) returns an object which, using the `ref' function, can be + used to read or set the value of PLACE. It's cheesy because it uses + closures rather than actually taking the address of something. Also, + unlike Zetalisp, we don't overload `car' to do our dirty work." + (multiple-value-bind + (valtmps valforms newtmps setform getform) + (get-setf-expansion place env) + `(let* (,@(mapcar #'list valtmps valforms)) + (make-loc (lambda () ,getform) + (lambda (,@newtmps) ,setform))))) + +(export 'ref) +(declaim (inline ref (setf ref))) +(defun ref (loc) + "Fetch the value referred to by a locative." + (funcall (loc-reader loc))) +(defun (setf ref) (new loc) + "Store a new value in the place referred to by a locative." + (funcall (loc-writer loc) new)) + +(export 'with-locatives) +(defmacro with-locatives (locs &body body) + "Evaluate BODY with implicit locatives. + + LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a + symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it + defaults to SYM. As an abbreviation for a common case, LOCS may be a + symbol instead of a list. + + The BODY is evaluated in an environment where each SYM is a symbol macro + which expands to (ref LOC-EXPR) -- or, in fact, something similar which + doesn't break if LOC-EXPR has side-effects. Thus, references, including + `setf' forms, fetch or modify the thing referred to by the LOC-EXPR. + Useful for covering over where something uses a locative." + (setf locs (mapcar (lambda (item) + (cond ((atom item) (list item item)) + ((null (cdr item)) (list (car item) (car item))) + (t item))) + (if (listp locs) locs (list locs)))) + (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) + (ll (mapcar #'cadr locs)) + (ss (mapcar #'car locs))) + `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) + (symbol-macrolet (,@(mapcar (lambda (sym tmp) + `(,sym (ref ,tmp))) ss tt)) + ,@body)))) + +;;;-------------------------------------------------------------------------- ;;; Anaphorics. (export 'it) -- 2.11.0