"Fossies" - the Fresh Open Source Software Archive

Member "txr-218/tests/012/man-or-boy.tl" (20 Jun 2019, 2079 Bytes) of package /linux/misc/txr-218.tar.bz2:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 (defstruct (cbn-thunk get set) nil get set)
    2 
    3 (defmacro make-cbn-val (place)
    4   (with-gensyms (nv tmp)
    5     (cond
    6       ((constantp place)
    7         ^(let ((,tmp ,place))
    8            (new cbn-thunk
    9              get (lambda () ,tmp)
   10              set (lambda (,nv) (set ,tmp ,nv)))))
   11       ((bindable place)
   12         ^(new cbn-thunk
   13            get (lambda () ,place)
   14            set (lambda (,nv) (set ,place ,nv))))
   15       (t
   16         ^(new cbn-thunk
   17            get (lambda () ,place)
   18            set (lambda (ign) (error "cannot set ~s" ',place)))))))
   19 
   20 (defun cbn-val (cbs)
   21   (call cbs.get))
   22 
   23 (defun set-cbn-val (cbs nv)
   24   (call cbs.set nv))
   25 
   26 (defplace (cbn-val thunk) body
   27   (getter setter
   28     (with-gensyms (thunk-tmp)
   29       ^(rlet ((,thunk-tmp ,thunk))
   30          (macrolet ((,getter () ^(cbn-val ,',thunk-tmp))
   31                     (,setter (val) ^(set-cbn-val ,',thunk-tmp ,val)))
   32        ,body)))))
   33 
   34 (defun make-cbn-fun (sym args . body)
   35   (let ((gens (mapcar (ret (gensym)) args)))
   36     ^(,sym ,gens
   37        (symacrolet ,[mapcar (ret ^(,@1 (cbn-val ,@2))) args gens]
   38          ,*body))))
   39 
   40 (defmacro cbn (fun . args)
   41   ^(call (fun ,fun) ,*[mapcar (ret ^(make-cbn-val ,@1)) args]))
   42 
   43 (defmacro defun-cbn (name (. args) . body)
   44   (with-gensyms (hidden-fun)
   45     ^(progn
   46        (defun ,hidden-fun ())
   47        (defmacro ,name (. args) ^(cbn ,',hidden-fun ,*args))
   48        (set (symbol-function ',hidden-fun)
   49             ,(make-cbn-fun 'lambda args
   50                            ^(block ,name (let ((,name)) ,*body ,name)))))))
   51 
   52 (defmacro labels-cbn ((name (. args) . lbody) . body)
   53   (with-gensyms (hidden-fun)
   54     ^(macrolet ((,name (. args) ^(cbn ,',hidden-fun ,*args)))
   55        (labels (,(make-cbn-fun hidden-fun args
   56                                ^(block ,name (let ((,name)) ,*lbody ,name))))
   57          ,*body))))
   58 
   59 (defun-cbn A (k x1 x2 x3 x4 x5)
   60   (let ((k k))
   61     (labels-cbn (B ()
   62                   (dec k)
   63                   (set B (set A (A k (B) x1 x2 x3 x4))))
   64       (if (<= k 0)
   65         (set A (+ x4 x5))
   66         (B))))) ;; value of (B) correctly discarded here!
   67 
   68 (prinl (A 10 1 -1 -1 1 0))