Coverage report: /home/ellis/comp/core/lib/syn/gen/read.lisp

KindCoveredAll%
expression4766 71.2
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; read.lisp --- Codegen Reader Macros
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :syn/gen)
7
 
8
 (defmacro define-code-reader (&key file-reader string-reader macro-character)
9
   `(progn
10
      (defun ,file-reader (file)
11
        ,(format nil "Read ~X source code file and return AST." (package-name *package*))
12
        (let ((ast)
13
              (*readtable* (copy-readtable nil)))
14
          (setf (readtable-case *readtable*) :invert)
15
          ,@macro-character
16
          (with-open-file (f file)
17
            (loop for form = (read f nil nil nil)
18
                  while form
19
                  do
20
                  (let* ((form (eval form))
21
                         (evaled (if (consp form)
22
                                     form
23
                                     (list form))))
24
                    (when (typep (car evaled) 'node)
25
                      (setf ast (append ast evaled))))))
26
          (make-instance 'ast :ast ast)))
27
      (defun ,string-reader (str)
28
        "Read syn/gen source code string and return AST."
29
        (let ((ast)
30
              (*readtable* (copy-readtable nil)))
31
          (setf (readtable-case *readtable*) :invert)
32
          ,@macro-character
33
          (let* ((form (eval (read-from-string str)))
34
                 (evaled (if (consp form)
35
                             form
36
                             (list form))))
37
            (when (typep (car evaled) 'node)
38
              (setf ast evaled)))
39
          (make-instance 'ast :ast ast)))))
40
 
41
 (defmacro define-code-processor (name &key file-reader string-reader traverse)
42
   (let ((extras (loop for i in traverse collect
43
                          `(traverse (make-instance ',i) tree 0))))
44
     `(defun ,name (in &optional out)
45
      (let ((tree)
46
            (printer (make-instance 'code-printer)))
47
        (setf tree (if (pathnamep in) (,file-reader in) (,string-reader in)))
48
        ,@extras
49
        (if out
50
            (with-open-file
51
                (stream out :direction :output
52
                            :if-exists :supersede
53
                            :if-does-not-exist :create)
54
              (setf (slot-value printer 'stream) stream)
55
              (traverse printer tree 0))
56
            (progn
57
              (setf (slot-value printer 'stream) *standard-output*)
58
              (traverse printer tree 0)
59
              (format t "~&")))))))
60
 
61
 (defmacro define-code-switch (name &key macro-character)
62
   "Define a syn/gen reader switch (in repl) allowing preprocessing and mixed
63
 case."
64
   `(defun ,name ()
65
      (cond ((eql *code-reader* 'cl)
66
             (setf *code-reader* 'gen)
67
             ,@macro-character
68
             (setf (readtable-case *readtable*) :invert))
69
            ((eql *code-reader* 'gen)
70
             (setf *code-reader* 'cl)
71
             (setf *readtable* *backup-readtable*))
72
            (t (error "Unknown code reader status: ~A" *code-reader*)))))
73
 
74
 (defmacro define-code-switches (&key cl-reader code-reader macro-character)
75
   "Define syn/gen and common-lisp reader switches."
76
   `(progn
77
      ,@(when cl-reader
78
          `((defun ,cl-reader ()
79
              (setf *code-reader* 'cl
80
                    *readtable* *backup-readtable*
81
                    (readtable-case *readtable*) *print-case*
82
                    *package* *default-package*))))
83
      (defun ,code-reader ()
84
        (setf *code-reader* 'gen)
85
        ,@macro-character
86
        (setf (readtable-case *readtable*) :invert))))
87
 
88
 ;;; Context switches
89
 (defun build-context-switches (&key package symbols)
90
   (let ((lisp-macrolet
91
          (loop for i in symbols collect
92
            (let ((symbol (format nil "~a" i)))
93
              ;; get <package>::<symbol> name
94
              `(,(intern symbol package) (&rest rest)
95
                ;; map to cl::<symbol> 
96
                (list* ',i rest)))))
97
         (gen-macrolet
98
          (loop for i in symbols collect
99
            (let ((symbol (intern (format nil "~a" i) package)))
100
              ;; get <package>::<symbol> name
101
              `(,symbol (&rest rest)
102
                ;; map to its macroexpansion
103
                ;; -> expansion without local environment
104
                (macroexpand-1 `(,',symbol ,@rest))))))
105
         (lisp-switch (intern "LISP" package))
106
         (gen-switch (intern "GEN" package)))
107
     (eval
108
      `(progn
109
         ;; define macro package::lisp
110
         ;; use common-lisp functions for macrolet scope
111
         (defmacro ,lisp-switch (&body body)
112
           `(macrolet ,',lisp-macrolet ,@body))
113
         ;; define macro package::gen
114
         ;; use syn/gen functions for macrolet scope
115
         ;; used to switch back within lisp-scope
116
         (defmacro ,gen-switch (&body body)
117
           `(macrolet ,',gen-macrolet (progn ,@body)))))))
118
 
119
 (defun build-swap-package (&key package swap-package symbols)
120
   (eval
121
    `(progn
122
       ,@(loop for i in symbols collect
123
           (let ((gen-symbol (intern (format nil "~a" i) package))
124
                 (sw-symbol (intern (format nil "~a" i) swap-package)))
125
             `(defmacro ,sw-symbol (&rest rest)
126
                (macroexpand-1 `(,',gen-symbol ,@rest))))))))