Prev: Mistake in the specification of rotatef ?
Next: [ann] LTK based libraries Runtime Library 3.0 and Gestalt Items 1.1
From: Vassil Nikolov on 4 Nov 2009 23:25

;; LLET is a substitute for LET (for lexical variables) and LFUNCTION
;; is a substitute for FUNCTION for closing over LLET's bindings (as
;; well as LET's). The macroexpansions do not contain LET forms for
;; lexical variables; no code walking is performed; EVAL and APPLY are
;; not involved; these constructs can be mixed with standard Common
;; Lisp constructs. I don't know what exactly constraints, and how
;; different from the above, various interested parties may have in
;; mind.

;; Some tests are given below. I may or may not get around to setting
;; up proper test drivers for this (which automatically compare the
;; results before and after substituting LET and FUNCTION for LLET and
;; LFUNCTION, something that poses no technical difficulties).

;; This was written from scratch, but I am not the inventor of any of
;; this approach, I don't think. In part, it matches one of Rob
;; Warnock's sketches in a recent post. Disclaimers apply.


(defun get-var (binding)
"Return the variable part of a binding (as a syntactic element).
<binding> ::= <varname> | (<varname>) | (<varname> <initform>)."
(check-type binding (not null))
(if (listp binding) (first binding) binding))

(defun get-value (binding)
"Return the initialization-form part of a binding."
(if (listp binding) (second binding) 'nil))

(defun augment-lenv (var value lenv)
(acons var value lenv))

(defmacro augment*-lenv (bindings lenv)
"Expand into AUGMENT-LENV calls to add bindings to an environment."
(if (endp bindings) lenv
(destructuring-bind (b &rest bs) bindings
`(augment-lenv ',(get-var b) ,(get-value b) (augment*-lenv ,bs ,lenv)))))

(defun lvar (var lenv)
"Accessor for a simulated local lexical variable."
(cdr (assoc var lenv)))

(defun (setf lvar) (value var lenv)
(setf (cdr (assoc var lenv)) value))

(defun make-contour ()
(gensym "CONTOUR-"))

(defun lenv (contour)
"Accessor for the lexical environment of a lexical contour."
(symbol-value contour))

(defun (setf lenv) (value contour)
(setf (symbol-value contour) value))

(defun lbinding (var contour)
"Construct a binding (as a syntactic element) for a simulated variable."
`(,var (lvar ',var (lenv ,contour))))

(defun make-lclosure (fn contour)
"Combine a captured simulated lexical environment with a function."
(if contour
(coerce `(lambda (&rest args)
(progv '(,contour) '(,(lenv contour)) (apply ',fn args)))
'function)
fn))

;; the current (simulated) lexical contour:
(define-symbol-macro %lcontour% nil)

;; the work horses:

(defmacro lfunction (name)
`(make-lclosure (function ,name) %lcontour%))

(defmacro llet ((&rest bindings) &body body)
(if (null bindings) `(progn ,@body)
(let ((new-contour (make-contour)))
`(progn
(setf (lenv ',new-contour) (lenv %lcontour%))
(symbol-macrolet ((%lcontour% ',new-contour))
(setf (lenv %lcontour%) (augment*-lenv ,bindings (lenv %lcontour%)))
(symbol-macrolet (,@(mapcar #'(lambda (b)
(lbinding (get-var b) '%lcontour%))
bindings))
,@body))))))


;;; "control implementation" (to compare to Common Lisp itself):

(defmacro lfunction (name)
`(function ,name))

(defmacro llet (&body body)
`(let ,@body))


;;; testing:

(defun test-llet-1 (x0 x1 x2 x3 x4)
(llet ((x x0))
(llet ((f0 (lfunction (lambda (v) (prog1 x (setf x v)))))
(f1 (lfunction (lambda () x))))
(llet ((x~ x))
(setf x x1)
(llet ((x x2))
(list x (setf x x3) x~ (funcall f0 x4) (funcall f1) x))))))

(assert (equal (test-llet-1 'a 'b 'c 'd 'e) '(c d a b e d)))

;; TEST-LLET-2 is based on one of Ron Garret's tests, improved to
;; catch more non-solutions:

(defun make-pair-of-closures (i d)
(llet ((x i))
(list (lfunction (lambda ()
(list (incf x d) (incf x d) (incf x d))))
(lfunction (lambda ()
(list (decf x d) (decf x d)))))))

(defun test-llet-2 (i1 d1 i2 d2)
(let ((p1 (make-pair-of-closures i1 d1))
(p2 (make-pair-of-closures i2 d2)))
(list (funcall (first p1))
(funcall (second p1))
(funcall (first p2))
(funcall (second p2)))))

(assert (equal (test-llet-2 0 1 2 3) '((1 2 3) (2 1) (5 8 11) (8 5))))

(defun |Ron Garret's "acid test"| ()
(let ((l1 (llet ((x 1)) (list (lfunction (lambda () (incf x)))
(lfunction (lambda () (decf x))))))
(l2 (llet ((x 5)) (list (lfunction (lambda () (incf x)))
(lfunction (lambda () (decf x)))))))
(list (funcall (first l1)) (funcall (first l1)) (funcall (second l1))
(funcall (first l2)) (funcall (first l2)) (funcall (second l2)))))

(assert (equal (list (|Ron Garret's "acid test"|) (|Ron Garret's "acid test"|))
'((2 3 2 6 7 6) (2 3 2 6 7 6))))

---Vassil.


--
Vassil Nikolov <vnikolov(a)pobox.com>

(1) M(Gauss);
(2) M(a) if M(b) and declared(b, M(a)),
where M(x) := "x is a mathematician".
From: Ron Garret on 6 Nov 2009 01:06
In article <snzk4y5ha34.fsf(a)luna.vassil.nikolov.name>,
Vassil Nikolov <vnikolov(a)pobox.com> wrote:

> (defun make-lclosure (fn contour)
> "Combine a captured simulated lexical environment with a function."
> (if contour
> (coerce `(lambda (&rest args)
> (progv '(,contour) '(,(lenv contour)) (apply ',fn args)))
> 'function)
> fn))


Bravo! So Madhu was wrong about everything after all ;-)

rg
From: Madhu on 7 Nov 2009 21:07

* Ron Garret <rNOSPAMon-D15CCC.22064405112009(a)news.albasani.net> :
Wrote on Thu, 05 Nov 2009 22:06:47 -0800:

| Bravo! So Madhu was wrong about everything after all ;-)

You seem to have infected Kaz with the disease where you try to pass off
all your own mistakes by accusing the person who pointed your mistake
of the very mistake you make.

--
Madhu
From: Tobias C. Rittweiler on 11 Nov 2009 03:53
Vassil Nikolov <vnikolov(a)pobox.com> writes:

> ;; LLET is a substitute for LET (for lexical variables) and LFUNCTION
> ;; is a substitute for FUNCTION for closing over LLET's bindings (as
> ;; well as LET's). The macroexpansions do not contain LET forms for
> ;; lexical variables; no code walking is performed;

You know, there's a trick for a poor man's code-walker that could be
applied for pathological^W pedagogical cases like this. First SUBST
CL:LAMBDA, and CL:LET to gensyms, then bind these gensyms via MACROLET
and have your implementation walk the code for you.

-T.
From: Ron Garret on 11 Nov 2009 18:51
In article <87eio54f3b.fsf(a)freebits.de>,
"Tobias C. Rittweiler" <tcr(a)freebits.de.invalid> wrote:

> Vassil Nikolov <vnikolov(a)pobox.com> writes:
>
> > ;; LLET is a substitute for LET (for lexical variables) and LFUNCTION
> > ;; is a substitute for FUNCTION for closing over LLET's bindings (as
> > ;; well as LET's). The macroexpansions do not contain LET forms for
> > ;; lexical variables; no code walking is performed;
>
> You know, there's a trick for a poor man's code-walker that could be
> applied for pathological^W pedagogical cases like this. First SUBST
> CL:LAMBDA, and CL:LET to gensyms, then bind these gensyms via MACROLET
> and have your implementation walk the code for you.

It's good for more than just pedagogy (and pathology). Pascal Costanza
has recently shown how to use it to implement hygienic macros:

http://p-cos.net/documents/hygiene.pdf

rg
 |  Next  |  Last
Pages: 1 2 3 4 5 6 7 8 9 10 11
Prev: Mistake in the specification of rotatef ?
Next: [ann] LTK based libraries Runtime Library 3.0 and Gestalt Items 1.1