-(define-module (lang elisp transform)
- #:use-module (lang elisp internals trace)
- #:use-module (lang elisp internals fset)
- #:use-module (lang elisp internals evaluation)
- #:use-module (ice-9 session)
- #:export (transformer transform))
-
-;;; {S-expressions}
-;;;
-
-(define (syntax-error x)
- (error "Syntax error in expression" x))
-
-;; Should be made mutating instead of constructing
-;;
-(define (transformer x)
- (cond ((eq? x 'nil) %nil)
- ((eq? x 't) #t)
- ((null? x) '())
- ((not (pair? x)) x)
- ((and (pair? (car x))
- (eq? (caar x) 'quasiquote))
- (transformer (car x)))
- ((symbol? (car x))
- (case (car x)
- ((@fop @bind define-module use-modules use-syntax) x)
- ; Escape to Scheme syntax
- ((scheme) (cons begin (cdr x)))
- ; Should be handled in reader
- ((quote function) `(,quote ,@(cars->nil (cdr x))))
- ((quasiquote) (m-quasiquote x '()))
- ;((nil-cond) (transform-1 x))
- ;((let) (m-let x '()))
- ;((let*) (m-let* x '()))
- ;((if) (m-if x '()))
- ;((and) (m-and x '()))
- ;((or) (m-or x '()))
- ;((while) (m-while x '()))
- ;((while) (cons macro-while (cdr x)))
- ;((prog1) (m-prog1 x '()))
- ;((prog2) (m-prog2 x '()))
- ;((progn) (cons 'begin (map transformer (cdr x))))
- ;((cond) (m-cond x '()))
- ;((lambda) (transform-lambda/interactive x '<elisp-lambda>))
- ;((defun) (m-defun x '()))
- ;((defmacro) (m-defmacro x '()))
- ;((setq) (m-setq x '()))
- ;((interactive) (fluid-set! interactive-spec x) #f)
- ;((unwind-protect) (m-unwind-protect x '()))
- (else (transform-application x))))
- (else (syntax-error x))))
-
-(define (m-quasiquote exp env)
- (cons 'quasiquote
- (map transform-inside-qq (cdr exp))))
-
-(define (transform-inside-qq x)
- (trc 'transform-inside-qq x)
- (cond ((not (pair? x)) x)
- ((symbol? (car x))
- (case (car x)
- ((unquote) (list 'unquote (transformer (cadr x))))
- ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))
- (else (cons (car x) (map transform-inside-qq (cdr x))))))
- (else
- (cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x))))))
-
-(define (transform-application x)
- (cons-source x
- '@fop
- `(,(car x) (,transformer-macro ,@(cdr x)))))
-
-(define transformer-macro
- (procedure->memoizing-macro
- (let ((cdr cdr))
- (lambda (exp env)
- (cons 'list (map transformer (cdr exp)))))))
-
-(define (cars->nil ls)
- (cond ((not (pair? ls)) ls)
- ((null? (car ls)) (cons '() (cars->nil (cdr ls))))
- (else (cons (cars->nil (car ls))
- (cars->nil (cdr ls))))))
-
-(define transform transformer)
+(define-module (lang elisp transform)
+ #:use-module (lang elisp internals trace)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals evaluation)
+ #:use-module (ice-9 session)
+ #:export (transformer transform))
+
+;;; A note on the difference between `(transform-* (cdr x))' and `(map
+;;; transform-* (cdr x))'.
+;;;
+;;; In most cases, none, as most of the transform-* functions are
+;;; recursive.
+;;;
+;;; However, if (cdr x) is not a proper list, the `map' version will
+;;; signal an error immediately, whereas the non-`map' version will
+;;; produce a similarly improper list as its transformed output. In
+;;; some cases, improper lists are allowed, so at least these cases
+;;; require non-`map'.
+;;;
+;;; Therefore we use the non-`map' approach in most cases below, but
+;;; `map' in transform-application, since in the application case we
+;;; know that `(func arg . args)' is an error. It would probably be
+;;; better for the transform-application case to check for an improper
+;;; list explicitly and signal a more explicit error.
+
+(define (syntax-error x)
+ (error "Syntax error in expression" x))
+
+(define-macro (scheme exp . module)
+ (let ((m (if (null? module)
+ the-root-module
+ (save-module-excursion
+ (lambda ()
+ ;; In order for `resolve-module' to work as
+ ;; expected, the current module must contain the
+ ;; `app' variable. This is not true for #:pure
+ ;; modules, specifically (lang elisp base). So,
+ ;; switch to the root module (guile) before calling
+ ;; resolve-module.
+ (set-current-module the-root-module)
+ (resolve-module (car module)))))))
+ (let ((x `(,eval (,quote ,exp) ,m)))
+ ;;(write x)
+ ;;(newline)
+ x)))
+
+(define (transformer x)
+ (cond ((pair? x)
+ (cond ((symbol? (car x))
+ (case (car x)
+ ;; Allow module-related forms through intact.
+ ((define-module use-modules use-syntax)
+ x)
+ ;; Escape to Scheme.
+ ((scheme)
+ (cons-source x scheme (cdr x)))
+ ;; Quoting.
+ ((quote function)
+ (cons-source x quote (transform-quote (cdr x))))
+ ((quasiquote)
+ (cons-source x quasiquote (transform-quasiquote (cdr x))))
+ ;; Anything else is a function or macro application.
+ (else (transform-application x))))
+ ((and (pair? (car x))
+ (eq? (caar x) 'quasiquote))
+ (transformer (car x)))
+ (else (syntax-error x))))
+ (else
+ (transform-datum x))))
+
+(define (transform-datum x)
+ (cond ((eq? x 'nil) %nil)
+ ((eq? x 't) #t)
+ ;; Could add other translations here, notably `?A' -> 65 etc.
+ (else x)))
+
+(define (transform-quote x)
+ (trc 'transform-quote x)
+ (cond ((not (pair? x))
+ (transform-datum x))
+ (else
+ (cons-source x
+ (transform-quote (car x))
+ (transform-quote (cdr x))))))
+
+(define (transform-quasiquote x)
+ (trc 'transform-quasiquote x)
+ (cond ((not (pair? x))
+ (transform-datum x))
+ ((symbol? (car x))
+ (case (car x)
+ ((unquote) (list 'unquote (transformer (cadr x))))
+ ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))
+ (else (cons-source x
+ (transform-datum (car x))
+ (transform-quasiquote (cdr x))))))
+ (else
+ (cons-source x
+ (transform-quasiquote (car x))
+ (transform-quasiquote (cdr x))))))
+
+(define (transform-application x)
+ (cons-source x @fop `(,(car x) (,transformer-macro ,@(map transform-quote (cdr x))))))
+
+(define transformer-macro
+ (procedure->memoizing-macro
+ (let ((cdr cdr))
+ (lambda (exp env)
+ (cons-source exp list (map transformer (cdr exp)))))))
+
+(define transform transformer)
HCoop / bpt / guile.git / blobdiff