home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / guile / 1.6 / ice-9 / syncase.scm < prev    next >
Encoding:
Text File  |  2006-06-19  |  9.0 KB  |  277 lines

  1. ;;;;     Copyright (C) 1997, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16. ;;;; Boston, MA 02110-1301 USA
  17. ;;;;
  18. ;;;; As a special exception, the Free Software Foundation gives permission
  19. ;;;; for additional uses of the text contained in its release of GUILE.
  20. ;;;;
  21. ;;;; The exception is that, if you link the GUILE library with other files
  22. ;;;; to produce an executable, this does not by itself cause the
  23. ;;;; resulting executable to be covered by the GNU General Public License.
  24. ;;;; Your use of that executable is in no way restricted on account of
  25. ;;;; linking the GUILE library code into it.
  26. ;;;;
  27. ;;;; This exception does not however invalidate any other reasons why
  28. ;;;; the executable file might be covered by the GNU General Public License.
  29. ;;;;
  30. ;;;; This exception applies only to the code released by the
  31. ;;;; Free Software Foundation under the name GUILE.  If you copy
  32. ;;;; code from other Free Software Foundation releases into a copy of
  33. ;;;; GUILE, as the General Public License permits, the exception does
  34. ;;;; not apply to the code that you add in this way.  To avoid misleading
  35. ;;;; anyone as to the status of such modified files, you must delete
  36. ;;;; this exception notice from them.
  37. ;;;;
  38. ;;;; If you write modifications of your own for GUILE, it is your choice
  39. ;;;; whether to permit this exception to apply to your modifications.
  40. ;;;; If you do not wish that, delete this exception notice.
  41. ;;;; 
  42.  
  43.  
  44. (define-module (ice-9 syncase)
  45.   :use-module (ice-9 debug)
  46.   :use-module (ice-9 threads)
  47.   :export-syntax (sc-macro define-syntax define-syntax-public 
  48.                   eval-when fluid-let-syntax
  49.           identifier-syntax let-syntax
  50.           letrec-syntax syntax syntax-case  syntax-rules
  51.           with-syntax
  52.           include)
  53.   :export (sc-expand sc-expand3 install-global-transformer
  54.        syntax-dispatch syntax-error bound-identifier=?
  55.        datum->syntax-object free-identifier=?
  56.        generate-temporaries identifier? syntax-object->datum
  57.        void syncase))
  58.  
  59. ;; This is to avoid a deprecation warning about re-exporting eval.
  60. ;; When the re-exporting behavior of export is removed, removed this
  61. ;; code and include 'eval' in the export clause of define-module,
  62. ;; above.
  63.  
  64. (define eval #f)
  65. (export eval)
  66.  
  67.  
  68.  
  69. (define expansion-eval-closure (make-fluid))
  70.  
  71. (define (env->eval-closure env)
  72.   (or (and env
  73.        (car (last-pair env)))
  74.       (module-eval-closure the-root-module)))
  75.  
  76. (define sc-macro
  77.   (procedure->memoizing-macro
  78.     (lambda (exp env)
  79.       (with-fluids ((expansion-eval-closure (env->eval-closure env)))
  80.         (sc-expand exp)))))
  81.  
  82. ;;; Exported variables
  83.  
  84. (define sc-expand #f)
  85. (define sc-expand3 #f)
  86. (define sc-chi #f)
  87. (define install-global-transformer #f)
  88. (define syntax-dispatch #f)
  89. (define syntax-error #f)
  90.  
  91. (define bound-identifier=? #f)
  92. (define datum->syntax-object #f)
  93. (define free-identifier=? #f)
  94. (define generate-temporaries #f)
  95. (define identifier? #f)
  96. (define syntax-object->datum #f)
  97.  
  98. (define primitive-syntax '(quote lambda letrec if set! begin define or
  99.                and let let* cond do quasiquote unquote
  100.                unquote-splicing case))
  101.  
  102. (for-each (lambda (symbol)
  103.         (set-symbol-property! symbol 'primitive-syntax #t))
  104.       primitive-syntax)
  105.  
  106. ;;; Hooks needed by the syntax-case macro package
  107.  
  108. (define (void) *unspecified*)
  109.  
  110. (define andmap
  111.   (lambda (f first . rest)
  112.     (or (null? first)
  113.         (if (null? rest)
  114.             (let andmap ((first first))
  115.               (let ((x (car first)) (first (cdr first)))
  116.                 (if (null? first)
  117.                     (f x)
  118.                     (and (f x) (andmap first)))))
  119.             (let andmap ((first first) (rest rest))
  120.               (let ((x (car first))
  121.                     (xr (map car rest))
  122.                     (first (cdr first))
  123.                     (rest (map cdr rest)))
  124.                 (if (null? first)
  125.                     (apply f (cons x xr))
  126.                     (and (apply f (cons x xr)) (andmap first rest)))))))))
  127.  
  128. (define (error who format-string why what)
  129.   (start-stack 'syncase-stack
  130.            (scm-error 'misc-error
  131.               who
  132.               "~A ~S"
  133.               (list why what)
  134.               '())))
  135.  
  136. (define the-syncase-module (current-module))
  137. (define the-syncase-eval-closure (module-eval-closure the-syncase-module))
  138.  
  139. (fluid-set! expansion-eval-closure the-syncase-eval-closure)
  140.  
  141. (define (putprop symbol key binding)
  142.   (let* ((eval-closure (fluid-ref expansion-eval-closure))
  143.      ;; Why not simply do (eval-closure symbol #t)?
  144.      ;; Answer: That would overwrite imported bindings
  145.      (v (or (eval-closure symbol #f) ;lookup
  146.         (eval-closure symbol #t) ;create it locally
  147.         )))
  148.     ;; Don't destroy Guile macros corresponding to
  149.     ;; primitive syntax when syncase boots.
  150.     (if (not (and (symbol-property symbol 'primitive-syntax)
  151.           (eq? eval-closure the-syncase-eval-closure)))
  152.     (variable-set! v sc-macro))
  153.     ;; Properties are tied to variable objects
  154.     (set-object-property! v key binding)))
  155.  
  156. (define (getprop symbol key)
  157.   (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
  158.     (and v
  159.      (or (object-property v key)
  160.          (and (variable-bound? v)
  161.           (macro? (variable-ref v))
  162.           (macro-transformer (variable-ref v)) ;non-primitive
  163.           guile-macro)))))
  164.  
  165. (define guile-macro
  166.   (cons 'external-macro
  167.     (lambda (e r w s)
  168.       (let ((e (syntax-object->datum e)))
  169.         (if (symbol? e)
  170.         ;; pass the expression through
  171.         e
  172.         (let* ((eval-closure (fluid-ref expansion-eval-closure))
  173.                (m (variable-ref (eval-closure (car e) #f))))
  174.           (if (eq? (macro-type m) 'syntax)
  175.               ;; pass the expression through
  176.               e
  177.               ;; perform Guile macro transform
  178.               (let ((e ((macro-transformer m)
  179.                 e
  180.                 (append r (list eval-closure)))))
  181.             (if (null? r)
  182.                 (sc-expand e)
  183.                 (sc-chi e r w))))))))))
  184.  
  185. (define generated-symbols (make-weak-key-hash-table 1019))
  186.  
  187. ;; We define our own gensym here because the Guile built-in one will
  188. ;; eventually produce uninterned and unreadable symbols (as needed for
  189. ;; safe macro expansions) and will the be inappropriate for dumping to
  190. ;; pssyntax.pp.
  191. ;;
  192. ;; syncase is supposed to only require that gensym produce unique
  193. ;; readable symbols, and they only need be unique with respect to
  194. ;; multiple calls to gensym, not globally unique.
  195. ;;
  196.  
  197. (define gensym
  198.   (let ((counter 0))
  199.  
  200.     (define next-id
  201.       (if (provided? 'threads)
  202.           (let ((symlock (make-mutex)))
  203.             (lambda ()
  204.               (let ((result #f))
  205.                 (with-mutex symlock
  206.                   (set! result counter)
  207.                   (set! counter (+ counter 1)))
  208.                 result)))
  209.           ;; faster, non-threaded case.
  210.           (lambda ()
  211.             (let ((result counter))
  212.               (set! counter (+ counter 1))
  213.               result))))
  214.     
  215.     ;; actual gensym body code.
  216.     (lambda (. rest)
  217.       (let* ((next-val (next-id))
  218.              (valstr (number->string next-val)))
  219.           (cond
  220.            ((null? rest)
  221.             (string->symbol (string-append "syntmp-" valstr)))
  222.            ((null? (cdr rest))
  223.             (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
  224.            (else
  225.             (error
  226.              (string-append
  227.               "syncase's gensym expected 0 or 1 arguments, got "
  228.               (length rest)))))))))
  229.  
  230. ;;; Load the preprocessed code
  231.  
  232. (let ((old-debug #f)
  233.       (old-read #f))
  234.   (dynamic-wind (lambda ()
  235.           (set! old-debug (debug-options))
  236.           (set! old-read (read-options)))
  237.         (lambda ()
  238.           (debug-disable 'debug 'procnames)
  239.           (read-disable 'positions)
  240.           (load-from-path "ice-9/psyntax.pp"))
  241.         (lambda ()
  242.           (debug-options old-debug)
  243.           (read-options old-read))))
  244.  
  245.  
  246. (define internal-eval (nested-ref the-scm-module '(app modules guile eval)))
  247.  
  248. (define (eval x environment)
  249.   (internal-eval (if (and (pair? x)
  250.               (equal? (car x) "noexpand"))
  251.              (cadr x)
  252.              (sc-expand x))
  253.          environment))
  254.  
  255. ;;; Hack to make syncase macros work in the slib module
  256. (let ((m (nested-ref the-root-module '(app modules ice-9 slib))))
  257.   (if m
  258.       (set-object-property! (module-local-variable m 'define)
  259.                 '*sc-expander*
  260.                 '(define))))
  261.  
  262. (define (syncase exp)
  263.   (with-fluids ((expansion-eval-closure
  264.          (module-eval-closure (current-module))))
  265.     (sc-expand exp)))
  266.  
  267. (set-module-transformer! the-syncase-module syncase)
  268.  
  269. (define-syntax define-syntax-public
  270.   (syntax-rules ()
  271.     ((_ name rules ...)
  272.      (begin
  273.        ;(eval-case ((load-toplevel) (export-syntax name)))
  274.        (define-syntax name rules ...)))))
  275.  
  276. (fluid-set! expansion-eval-closure (env->eval-closure #f))
  277.