home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / lang / elisp / transform.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  3.5 KB  |  112 lines
  1. (define-module (lang elisp transform)
  2.   #:use-module (lang elisp internals trace)
  3.   #:use-module (lang elisp internals fset)
  4.   #:use-module (lang elisp internals evaluation)
  5.   #:use-module (ice-9 session)
  6.   #:export (transformer transform))
  7.  
  8. ;;; A note on the difference between `(transform-* (cdr x))' and `(map
  9. ;;; transform-* (cdr x))'.
  10. ;;;
  11. ;;; In most cases, none, as most of the transform-* functions are
  12. ;;; recursive.
  13. ;;;
  14. ;;; However, if (cdr x) is not a proper list, the `map' version will
  15. ;;; signal an error immediately, whereas the non-`map' version will
  16. ;;; produce a similarly improper list as its transformed output.  In
  17. ;;; some cases, improper lists are allowed, so at least these cases
  18. ;;; require non-`map'.
  19. ;;;
  20. ;;; Therefore we use the non-`map' approach in most cases below, but
  21. ;;; `map' in transform-application, since in the application case we
  22. ;;; know that `(func arg . args)' is an error.  It would probably be
  23. ;;; better for the transform-application case to check for an improper
  24. ;;; list explicitly and signal a more explicit error.
  25.  
  26. (define (syntax-error x)
  27.   (error "Syntax error in expression" x))
  28.  
  29. (define-macro (scheme exp . module)
  30.   (let ((m (if (null? module)
  31.            the-root-module
  32.            (save-module-excursion
  33.         (lambda ()
  34.           ;; In order for `resolve-module' to work as
  35.           ;; expected, the current module must contain the
  36.           ;; `app' variable.  This is not true for #:pure
  37.           ;; modules, specifically (lang elisp base).  So,
  38.           ;; switch to the root module (guile) before calling
  39.           ;; resolve-module.
  40.           (set-current-module the-root-module)
  41.           (resolve-module (car module)))))))
  42.     (let ((x `(,eval (,quote ,exp) ,m)))
  43.       ;;(write x)
  44.       ;;(newline)
  45.       x)))
  46.  
  47. (define (transformer x)
  48.   (cond ((pair? x)
  49.      (cond ((symbol? (car x))
  50.         (case (car x)
  51.           ;; Allow module-related forms through intact.
  52.           ((define-module use-modules use-syntax)
  53.            x)
  54.           ;; Escape to Scheme.
  55.           ((scheme)
  56.            (cons-source x scheme (cdr x)))
  57.           ;; Quoting.
  58.           ((quote function)
  59.            (cons-source x quote (transform-quote (cdr x))))
  60.           ((quasiquote)
  61.            (cons-source x quasiquote (transform-quasiquote (cdr x))))
  62.           ;; Anything else is a function or macro application.
  63.           (else (transform-application x))))
  64.            ((and (pair? (car x))
  65.              (eq? (caar x) 'quasiquote))
  66.         (transformer (car x)))
  67.            (else (syntax-error x))))
  68.     (else
  69.      (transform-datum x))))
  70.  
  71. (define (transform-datum x)
  72.   (cond ((eq? x 'nil) %nil)
  73.     ((eq? x 't) #t)
  74.     ;; Could add other translations here, notably `?A' -> 65 etc.
  75.     (else x)))
  76.  
  77. (define (transform-quote x)
  78.   (trc 'transform-quote x)
  79.   (cond ((not (pair? x))
  80.      (transform-datum x))
  81.     (else
  82.      (cons-source x
  83.               (transform-quote (car x))
  84.               (transform-quote (cdr x))))))
  85.  
  86. (define (transform-quasiquote x)
  87.   (trc 'transform-quasiquote x)
  88.   (cond ((not (pair? x))
  89.      (transform-datum x))
  90.     ((symbol? (car x))
  91.      (case (car x)
  92.        ((unquote) (list 'unquote (transformer (cadr x))))
  93.        ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))
  94.        (else (cons-source x
  95.                   (transform-datum (car x))
  96.                   (transform-quasiquote (cdr x))))))
  97.     (else
  98.      (cons-source x
  99.               (transform-quasiquote (car x))
  100.               (transform-quasiquote (cdr x))))))
  101.  
  102. (define (transform-application x)
  103.   (cons-source x @fop `(,(car x) (,transformer-macro ,@(map transform-quote (cdr x))))))
  104.  
  105. (define transformer-macro
  106.   (procedure->memoizing-macro
  107.    (let ((cdr cdr))
  108.      (lambda (exp env)
  109.        (cons-source exp list (map transformer (cdr exp)))))))
  110.  
  111. (define transform transformer)
  112.