guile18/lang/elisp/transform.scm

   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)