diff options
| -rw-r--r-- | share/txr/stdlib/ifa.tl | 25 | ||||
| -rw-r--r-- | share/txr/stdlib/place.tl | 38 | ||||
| -rw-r--r-- | share/txr/stdlib/txr-case.tl | 11 | ||||
| -rw-r--r-- | share/txr/stdlib/with-resources.tl | 4 |
4 files changed, 38 insertions, 40 deletions
diff --git a/share/txr/stdlib/ifa.tl b/share/txr/stdlib/ifa.tl index a4dd4738..239de517 100644 --- a/share/txr/stdlib/ifa.tl +++ b/share/txr/stdlib/ifa.tl @@ -24,7 +24,7 @@ ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -(defmacro ifa (:env e test then : else) +(defmacro ifa (:env e :form f test then : else) (flet ((candidate-p (form) (not (or (constantp form e) (symbolp form))))) (cond @@ -32,8 +32,7 @@ (if it ,then ,else))) ((member (first test) '(not null false)) (unless (eql (length test) 2) - (compile-error "~s: wrong number of arguments to ~s" - 'ifa (first test))) + (compile-error f "wrong number of arguments to ~s" (first test))) ^(ifa ,(second test) ,else ,then)) (t (let* ((sym (first test)) (args (if (eq 'dwim sym) (cddr test) (cdr test))) @@ -43,11 +42,11 @@ (and (or (functionp (symbol-function sym)) (eq sym 'dwim) (null (symbol-function sym))))) - (compile-error "~s: test expression must be \ - \ a simple function call" 'ifa)) + (compile-error f "test expression must be \ + \ a simple function call")) (when (> n-candidate-args 1) - (compile-error "~s: ambiguous situation: \ - \ not clear what can be \"it\"" 'ifa)) + (compile-error f "ambiguous situation: \ + \ not clear what can be \"it\"")) (iflet ((it-form (macroexpand [args pos-candidate] e)) (is-place (place-form-p it-form e))) (let ((before-it [args 0..pos-candidate]) @@ -69,15 +68,15 @@ (defmacro whena (test . body) ^(ifa ,test (progn ,*body))) -(defun sys:if-to-cond (if-oper cond-oper pairs) +(defun sys:if-to-cond (f if-oper cond-oper pairs) (tree-case pairs (((test . forms) . rest) ^(,if-oper ,test (progn ,*forms) (,cond-oper ,*rest))) (() ()) - (else (compile-error "~s: bad syntax: ~s" cond-oper pairs)))) + (else (compile-error f "bad syntax: ~s" pairs)))) -(defmacro conda (. pairs) - (sys:if-to-cond 'ifa 'conda pairs)) +(defmacro conda (:form f . pairs) + (sys:if-to-cond f 'ifa 'conda pairs)) -(defmacro condlet (. pairs) - (sys:if-to-cond 'iflet 'condlet pairs)) +(defmacro condlet (:form f . pairs) + (sys:if-to-cond f 'iflet 'condlet pairs)) diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl index 20405396..0aef499a 100644 --- a/share/txr/stdlib/place.tl +++ b/share/txr/stdlib/place.tl @@ -29,6 +29,7 @@ (defvar *place-delete-expander* (hash)) (defvar *place-macro* (hash)) (defvar sys:*pl-env* nil) +(defvar sys:*pl-form* nil) (defun sys:eval-err (. params) (throwf 'eval-error . params)) @@ -147,6 +148,7 @@ (let* ((place (sys:pl-expand unex-place env)) (expander (get-update-expander place)) (sys:*pl-env* env) + (sys:*pl-form* unex-place) (expansion [expander getter setter place body]) (expansion-ex (expand expansion env))) (sys:propagate-ancestor expansion-ex place getter setter))) @@ -156,6 +158,7 @@ (let* ((place (sys:pl-expand unex-place env)) (expander (get-clobber-expander place)) (sys:*pl-env* env) + (sys:*pl-form* unex-place) (expansion [expander ssetter place body]) (expansion-ex (expand expansion env))) (sys:propagate-ancestor expansion-ex place ssetter))) @@ -165,6 +168,7 @@ (let* ((place (sys:pl-expand unex-place env)) (expander (get-delete-expander place)) (sys:*pl-env* env) + (sys:*pl-form* unex-place) (expansion [expander deleter place body]) (expansion-ex (expand expansion env))) (sys:propagate-ancestor expansion-ex place deleter))) @@ -290,10 +294,10 @@ ,old-list-sym (,setter (cons ,new-item-sym ,old-list-sym))))))))) -(defmacro shift (:env env . places) +(defmacro shift (:form f :env env . places) (tree-case places - (() (compile-error "~s: need at least two arguments" 'shift)) - ((place) (compile-error "~s: need at least two arguments" 'shift)) + (() (compile-error f "need at least two arguments")) + ((place) (compile-error f "need at least two arguments")) ((place newvalue) (with-update-expander (getter setter) place env ^(prog1 (,getter) (,setter ,newvalue)))) @@ -339,14 +343,13 @@ (with-delete-expander (deleter) place env ^(,deleter))) -(defmacro lset (. places-source) +(defmacro lset (:form f . places-source) (let ((places (butlast places-source)) (source (last places-source)) (orig (gensym)) (iter (gensym))) (unless places - (compile-error "~s: require one or more places followed by expression" - 'lset)) + (compile-error f "require one or more places followed by expression")) ^(let* ((,orig ,(car source)) (,iter ,orig)) ,*(butlast (mappend (ret ^((set ,@1 (car ,iter)) (set ,iter (cdr ,iter)))) @@ -368,8 +371,7 @@ (symbolp name) (not (keywordp name)) (not (eq t name))) - (compile-error "~s: ~s cannot be used as a place name" - 'defplace name)) + (compile-error sys:*pl-form* "~s cannot be used as a place name" name)) (with-gensyms (place) ^(progn (sethash *place-update-expander* ',name @@ -768,9 +770,9 @@ (deleter ^(macrolet ((,deleter (:env env) (when (lexical-fun-p env ',sym) - (compile-error "~s is a lexical function, \ - \ thus not deletable" - ',sym)) + (compile-error ',sys:*pl-form* + "~s is a lexical function, \ + \ thus not deletable")) ^(fmakunbound ',',sym))) ,body))) @@ -811,14 +813,14 @@ ^(macrolet ((,deleter () ^(fmakunbound ,',sym-expr))) ,body))) -(defun sys:get-mb (sym) +(defun sys:get-mb (f sym) (or (gethash sys:top-mb sym) - (compile-error "unbound macro ~s" sym))) + (compile-error f "unbound macro ~s" sym))) (defplace (symbol-macro sym-expr) body (getter setter (with-gensyms (binding-sym) - ^(let ((,binding-sym (sys:get-mb ,sym-expr))) + ^(let ((,binding-sym (sys:get-mb ',sys:*pl-form* ,sym-expr))) (macrolet ((,getter () ^(cdr ,',binding-sym)) (,setter (val) ^(sys:rplacd ,',binding-sym ,val))) ,body)))) @@ -890,18 +892,18 @@ ,*body) env)))) (remhash *place-update-expander* tmp-place)))) -(defmacro placelet* (sym-place-pairs . body) +(defmacro placelet* (:form f sym-place-pairs . body) (tree-case sym-place-pairs (() ^(progn ,*body)) (((sym place)) ^(sys:placelet-1 ((,sym ,place)) ,*body)) (((sym place) . rest-pairs) ^(sys:placelet-1 ((,sym ,place)) (placelet* (,*rest-pairs) ,*body))) - (obj (compile-error "~s: bad syntax: ~s" 'placelet* obj)))) + (obj (compile-error f "bad syntax: ~s" obj)))) -(defmacro placelet (sym-place-pairs . body) +(defmacro placelet (:form f sym-place-pairs . body) (unless (all sym-place-pairs [andf consp (opip length (= 2)) (oand first bindable)]) - (compile-error "~s: bad syntax: ~s" 'placelet sym-place-pairs)) + (compile-error f "bad syntax: ~s" sym-place-pairs)) (tree-bind (: syms places) (transpose sym-place-pairs) (let ((temps (mapcar (ret (gensym)) syms))) ^(placelet* (,*(zip temps places)) diff --git a/share/txr/stdlib/txr-case.tl b/share/txr/stdlib/txr-case.tl index bef5b358..57e44643 100644 --- a/share/txr/stdlib/txr-case.tl +++ b/share/txr/stdlib/txr-case.tl @@ -45,7 +45,7 @@ (defmacro txr-when (name args input . body) ^(txr-if ,name ,args ,input (progn ,*body))) -(defmacro txr-case-impl (sym . clauses) +(defmacro txr-case-impl (:form f sym . clauses) (tree-case clauses (((name args . body) . other-clauses) (if (eq name t) : @@ -55,15 +55,12 @@ (((sym . rest) . other-clauses) (if (eq sym t) (if other-clauses - (compile-error "~s: clauses after (t ...) clause ignored" - 'txr-case) + (compile-error f "clauses after (t ...) clause ignored") ^(progn ,*rest)) - (compile-error "~s: bad syntax: ~s" (car clauses) - 'txr-case))) + (compile-error f "bad syntax: ~s" (car clauses)))) (() ()) (atom - (compile-error "~s: unexpected atom in syntax: ~s" - 'txr-case atom)))) + (compile-error f "unexpected atom in syntax: ~s" atom)))) (defmacro txr-case (input-expr . clauses) (let ((input (gensym "input-"))) diff --git a/share/txr/stdlib/with-resources.tl b/share/txr/stdlib/with-resources.tl index febf878b..0494982a 100644 --- a/share/txr/stdlib/with-resources.tl +++ b/share/txr/stdlib/with-resources.tl @@ -24,7 +24,7 @@ ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -(defmacro with-resources (res-bindings . body) +(defmacro with-resources (:form f res-bindings . body) (tree-case res-bindings (((sym init cleanup) . rest) ^(let ((,sym ,init)) @@ -40,7 +40,7 @@ (with-resources ,rest ,*body))) (nil ^(progn ,*body)) - (other (compile-error "~s: bad syntax" 'with-resources)))) + (other (compile-error f "bad syntax")))) (defmacro with-objects (var-init-forms . body) (let ((gens (mapcar (ret (gensym)) var-init-forms))) |