guile-log-pre.scm 3.83 KB
Newer Older
Stefan Israelsson Tampe committed
1
(define-module (logic guile-log guile-log-pre)
2
  #:use-module ((system syntax) #:select (syntax-local-binding))
3
  #:use-module (compat racket misc)
4
  #:export (define-guile-log guile-log-macro? log-code-macro log-code-macro?
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
	     define-and-log and-log-macro? bounded-equal? stx-case))

(define (bounded-equal? stx-x stx-y)
  (call-with-values (lambda () (syntax-local-binding stx-x))
    (lambda (type-x val-x)
      (lambda (type-y val-y)
	(and (equal? type-x type-y) (equal? val-x val-y))))))

(define-syntax-rule (stx-case x . l)
  (let ((xx x))
    (stx-case-w xx . l)))

(define-syntax stx-case-w
  (lambda (x)
    (syntax-case x (else)
      ((_ x (else . code))
       #'(begin . code))
      ((_ x ((m ...) code ...) . l)
       #'(if (and (bounded-equal? x m) ...)
	     (begin code ...)
	     (stx-case-w x . l)))
      ((_ x)
       #'(error "stx-case did not match")))))

Stefan Israelsson Tampe committed
29

30 31 32
(define *guile-log-macros* (make-weak-key-hash-table))
(define *log-code-macros*  (make-weak-key-hash-table))
(define *and-code-macros*  (make-weak-key-hash-table))
33

34 35 36 37 38 39 40 41 42 43 44
(define-syntax and-let*
  (syntax-rules ()
    ((_ ((x v) . l) . code)
     (let ((x v))
       (if x
	   (and-let* l . code)
	   #f)))
    ((_ ((x) . l) . code)
     (if x (and-let* l . code) #f))
    ((_ () . code)
     (begin . code))))
Stefan Israelsson Tampe committed
45

46 47 48 49 50 51 52 53 54 55
(define (setter table)
  (lambda (s)
    (if (and-let* (((symbol? s))
		   (m (module-ref (current-module) s))
		   ((macro? m))
		   (n (macro-binding m)))
	   (hash-set! table n #t)
	   #t)
	#t
	(warn (format #f "macro type setter fails, ~a is not a macro" s)))))
56

57 58

(define (tester table)
59
  (lambda (s)       
60
    (and (syntax? s)
61 62 63 64 65
         (syntax-case s (@@ @)
           (id
            (identifier? #'id)
            (call-with-values (lambda () (syntax-local-binding #'id))
              (lambda (type value)
66 67 68
                (let ((i (syntax->datum #'id)))
                  (if (eq? i '<let-with-lr-guard>)
		      `(tester ,type ,value ,#'id)))
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
                (case type
                  ((macro)
                   (hash-ref table value #f))
                  (else
                   #f)))))

           ((@ l nm)
            (catch #t
              (lambda ()
                (let ((l  (syntax->datum #'l))
                      (nm (syntax->datum #'nm)))
                  (let ((box (macro-binding 
                              (module-ref 
                               (resolve-module l) nm))))
                    (hash-ref table box #f))))
              (lambda x #f)))

           ((@@ l nm)
            (catch #t
              (lambda ()
                (let ((l  (syntax->datum #'l))
                      (nm (syntax->datum #'nm)))
                  (let ((box (macro-binding 
                              (module-ref 
                               (resolve-module l) nm))))
                    (hash-ref table box #f))))
              (lambda x #f)))
           
           (_ #f)))))
                
                
100 101 102 103 104 105 106

(define guile-log-macro?  (tester *guile-log-macros*))
(define and-log-macro?    (tester *and-code-macros*))
(define log-code-macro?   (tester *log-code-macros*))
(define guile-log-macro!  (setter *guile-log-macros*))
(define and-log-macro!    (setter *and-code-macros*))
(define log-code-macro!   (setter *log-code-macros*))
Stefan Israelsson Tampe committed
107

108
(define-syntax log-code-macro
109 110 111 112
  (lambda (x)
    (syntax-case x (quote)
      ((_ (quote x)) 
       #'(eval-when (compile load eval)
113 114
	   (begin             
             (log-code-macro! 'x) #f)))
115 116
      ((_ x)       
       #'(log-code-macro 'x)))))
Stefan Israelsson Tampe committed
117 118 119 120 121

(define-syntax define-guile-log
  (lambda (x)
    (syntax-case x ()
      ((_ n . l)
122 123 124 125 126 127
       #'(begin
	   (define-syntax n . l)
	   (eval-when (compile load eval)
	     (guile-log-macro! 'n)))))))
	   
	   
128 129 130 131 132

(define-syntax define-and-log
  (lambda (x)
    (syntax-case x ()
      ((_ n . l)
133 134 135 136
       #'(begin
	   (define-syntax n . l)
	   (eval-when (compile load eval)
	     (and-log-macro! 'n)))))))