Coverage report: /home/ellis/comp/core/std/macs/pan.lisp

KindCoveredAll%
expression2048 41.7
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; pan.lisp --- Pandoric macros
2
 
3
 ;;; Code:
4
 (in-package :std/macs)
5
 (in-readtable :std)
6
 
7
 (defun pandoriclet-get (letargs)
8
   "Primitive pandoric-get access to LETARGS."
9
   `(case sym
10
      ,@(mapcar #`(((car ,a1)) (car ,a1))
11
         letargs)
12
      (t (error
13
          "Unknown pandoric get: ~a"
14
          sym))))
15
 
16
 (defun pandoriclet-set (letargs)
17
   "Primitive pandoric-set access to LETARGS."
18
   `(case sym
19
      ,@(mapcar #`(((car ,a1))
20
                   (setq (car ,a1) val))
21
         letargs)
22
      (t (error
23
          "Unknown pandoric set: ~a"
24
          sym))))
25
 
26
 (defmacro pandoriclet (letargs &rest body)
27
   "Let-bind LETARGS and return a dlambda where they may be accessed via GET-PANDORIC."
28
   (let ((letargs (cons
29
                   '(%a)
30
                   (std/list:let-binding-transform
31
                    letargs))))
32
     `(let (,@letargs)
33
        (setq %a ,@(last body))
34
        ,@(butlast body)
35
        (dlambda
36
         (:pandoric-get (sym)
37
                        ,(pandoriclet-get letargs))
38
         (:pandoric-set (sym val)
39
                        ,(pandoriclet-set letargs))
40
         (t (&rest args)
41
            (apply %a args))))))
42
 
43
 (declaim (inline get-pandoric))
44
 
45
 (defun get-pandoric (box sym)
46
   "Get pandoric value SYM out of BOX."
47
   (funcall box :pandoric-get sym))
48
 
49
 (defsetf get-pandoric (box sym) (val)
50
   "Set pandoric value of SYM in BOX."
51
   `(progn
52
      (funcall ,box :pandoric-set ,sym ,val)
53
      ,val))
54
 
55
 
56
 (defmacro! with-pandoric (syms o!box &rest body)
57
   "Binds SYMS by calling GET-PANDORIC on BOX around BODY."
58
   `(symbol-macrolet
59
        (,@(mapcar #`(,a1 (get-pandoric ,g!box ,a1))
60
                   syms))
61
      ,@body))
62
 
63
 (defmacro pandoric-recode (vars box new)
64
   "Recode the pandoric BOX binding VARS to NEW."
65
   `(with-pandoric (%a ,@vars) ,box
66
      (setq %a ,new)))
67
 
68
 (defmacro plambda (largs pargs &rest body)
69
   "Define a pandoric lambda with lambda args LARGS and pandoric args PARGS."
70
   (let ((pargs (mapcar #'list pargs)))
71
     `(let (%a %p)
72
        (setq
73
         %a (lambda ,largs ,@body)
74
         %p (dlambda
75
               (:pandoric-get (sym)
76
                              ,(pandoriclet-get pargs))
77
               (:pandoric-set (sym val)
78
                              ,(pandoriclet-set pargs))
79
               (t (&rest args)
80
                  (apply %a args)))))))
81
 
82
 (defvar pandoric-eval-tunnel)
83
 
84
 (defmacro pandoric-eval (vars expr)
85
   "Evaluate pandoric expression EXPR using VARS bindings."
86
   `(let ((pandoric-eval-tunnel
87
            (plambda () ,vars t)))
88
      (eval `(with-pandoric
89
               ,',vars pandoric-eval-tunnel
90
               ,,expr))))