mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +02:00
Code Activity

* Complete Elisp translator work.

Browse source
This commit is contained in:
Neil Jerram 2002-02-08 11:50:51 +00:00
parent 1f761e0a59
commit e79236a948
19 changed files with 385 additions and 228 deletions
Download patch file Download diff file Expand all files Collapse all files

82
lang/elisp/ChangeLog
View file

@ -1,3 +1,85 @@
2002-02-08 Neil Jerram <neil@ossau.uklinux.net>
* STATUS: New file.
* README: Updated.
* interface.scm (translate-elisp): New exported procedure.
(elisp-function): Symbol var is `obj', not `symbol'.
* internals/lambda.scm, primitives/fns.scm: Fix confusion between
interactive-spec and interactive-specification.
* internals/lambda.scm (transform-lambda), primitives/syntax.scm
(defmacro): Bind unspecified optional and rest arguments to #nil,
not #f.
* internals/null.scm (->nil, lambda->nil): New, exported.
(null): Use ->nil.
* primitives/features.scm (featurep), primitives/fns.scm
(fboundp, subrp): Use ->nil.
* internals/lists.scm (cons, setcdr, memq, member, assq, assoc):
Simplified.
(car, cdr): Return #nil rather than #f.
* primitives/load.scm (current-load-list), primitives/pure.scm
(purify-flag): Set to #nil, not #f.
* primitives/match.scm (string-match): Return #nil rather than #f.
* primitives/numbers.scm (integerp, numberp),
primitives/strings.scm (string-lessp, stringp): Use lambda->nil.
* primitives/symprop.scm (boundp): Use ->nil.
(symbolp, local-variable-if-set-p): Return #nil rather than #f.
* primitives/syntax.scm (prog1, prog2): Mangle variable names
further to lessen possibility of conflicts.
(if, and, or, cond): Return #nil rather than #f.
(cond): Return #t rather than t (which is undefined).
(let, let*): Bind uninitialized variables to #nil, not #f.
* transform.scm: Resolve inconsistency in usage of `map', and add
an explanatory note. Also cleaned up use of subsidiary
transformation functions. Also use cons-source wherever possible.
(transform-datum, transform-quote): New.
(transform-quasiquote): Renamed from `transform-inside-qq'.
(transform-application): Apply `transform-quote' to application
args.
(cars->nil): Removed.
* internals/null.scm (null), primitives/lists.scm (cons, car, cdr,
setcdr, memq, member, assq, assoc, nth): Update to take into
account new libguile support for Elisp nil value.
2002-02-06 Neil Jerram <neil@ossau.uklinux.net>
* example.el (time): New macro, for performance measurement.
Accompanying comment compares results for Guile and Emacs.
* transform.scm (scheme): New macro.
(transformer): New implementation of `scheme' escape that doesn't
rely on (lang elisp base) importing Guile bindings.
* base.scm: No longer import anything from (guile).
(load-emacs): Add scheme form to ensure that keywords
read option is set correctly.
* primitives/syntax.scm (defmacro, let, let*): Unquote uses of
`@bind' in transformed code.
(if): Unquote uses of `nil-cond' in transformed code.
* internals/lambda.scm (transform-lambda): Unquote use of `@bind'
in transformed code.
* transform.scm (transformer-macro): Don't quote `list' in
transformed code.
(transform-application): Don't quote `@fop' in transformed code.
(transformer): No need to treat `@bind' and `@fop' as special
cases in input to the transformer.
2002-02-04 Neil Jerram <neil@ossau.uklinux.net>
* primitives/syntax.scm (parse-formals, transform-lambda,

72
lang/elisp/README
View file

@ -45,8 +45,7 @@ and try to bootstrap a complete Emacs environment:
* Status
Please note that this is work in progress; the translator is
incomplete and not yet widely tested.
Please see the STATUS file for the full position.
** Trying to load a complete Emacs environment.
@ -163,12 +162,23 @@ transform Elisp variable references after all.
*** Truth value stuff
Lots of stuff to do with providing the special self-evaluating `nil'
and `t' symbols, and macros that convert between Scheme and Elisp
truth values, and so on.
Following extensive discussions on the Guile mailing list between
September 2001 and January 2002, we decided to go with Jim Blandy's
proposal. See devel/translation/lisp-and-scheme.text for details.
I'm hoping that most of this will go away, but I need to show that
it's feasible first.
- The Elisp nil value is a new immediate SCM_MAKIFLAG, eq?-distinct
from both #f and '() (and of course any other Scheme value). It can
be accessed via the (guile) binding `%nil', and prints as `#nil'.
- All Elisp primitives treat #nil, #f and '() as identical.
- Scheme truth-testing primitives have been modified so that they
treat #nil the same as #f.
- Scheme list-manipulating primitives have been modified so that they
treat #nil the same as '().
- The Elisp t value is the same as #t.
** Emacs editing primitives
@ -191,8 +201,9 @@ that Ken Raeburn has been doing on the Emacs codebase.
Elisp is close enough to Scheme that it's convenient to coopt the
existing Guile reader rather than to write a new one from scratch, but
there are a few syntactic differences that will require adding Elisp
support to the reader.
there are a few syntactic differences that will require changes in
reading and printing. None of the following changes has yet been
implemented.
- Character syntax is `?a' rather than `#\a'. (Not done. More
precisely, `?a' in Elisp isn't character syntax but an alternative
@ -204,12 +215,10 @@ support to the reader.
and so on.)
- `nil' and `t' should be read (I think) as #f and #t. (Done.)
- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'.
- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'. (Not done.)
Correspondingly, when printing, #f and '() should be written as
`nil'. (Not done.)
- When in an Elisp environment, #nil and #t should print as `nil' and
`t'.
** The Elisp evaluation module (lang elisp base)
@ -272,36 +281,6 @@ worry about adding unexec support to Guile!) For the output that
currently results from calling `(load-emacs)', see above in the Status
section.
* nil, #f and '()
For Jim Blandy's notes on this, see the reference at the bottom of
this file. Currently I'm investigating a different approach, which is
better IMO than Jim's proposal because it avoids requiring multiple
false values in the Scheme world.
According to my approach...
- `nil' and `t' are read (when in Elisp mode) as #f and #t.
- `(if x ...)', `(while x ...)' etc. are translated to something
like `(if (and x (not (null? x))) ...)'.
- Functions which interpret an argument as a list --
`cons', `setcdr', `memq', etc. -- either convert #f to '(), or
handle the #f case specially.
- `eq' treats #f and '() as the same.
- Optionally, functions which produce '() values -- i.e. the reader
and `cdr' -- could convert those immediately to #f. This shouldn't
affect the validity of any Elisp code, but it alters the balance of
#f and '() values swimming around in that code and so affects what
happens if two such values are returned to the Scheme world and then
compared. However, since you can never completely solve this
problem (unless you are prepared to convert arbitrarily deep
structures on entry to the Elisp world, which would kill performance),
I'm inclined not to try to solve it at all.
* Resources
** Ken Raeburn's Guile Emacs page
@ -316,6 +295,9 @@ http://gemacs.sourceforge.net
http://sanpietro.red-bean.com/guile/guile/old/3114.html
Also now stored as guile-core/devel/translation/lisp-and-scheme.text
in Guile CVS.
** Mikael Djurfeldt's notes on translation
See file guile-cvs/devel/translation/langtools.text in Guile CVS.
See file guile-core/devel/translation/langtools.text in Guile CVS.

35
lang/elisp/STATUS Normal file
View file

@ -0,0 +1,35 @@
-*-text-*-
I've now finished my currently planned work on the Emacs Lisp
translator in guile-core CVS.
It works well enough for experimentation and playing around with --
see the README file for details of what it _can_ do -- but has two
serious restrictions:
- Most Emacs Lisp primitives are not yet implemented. In particular,
there are no buffer-related primitives.
- Performance compares badly with Emacs. Using a handful of
completely unscientific tests, I found that Guile was between 2 and
20 times slower than Emacs. (See the comment in
lang/elisp/example.el for details of tests and results.)
Interestingly, both these restrictions point in the same direction:
the way forward is to define the primitives by compiling a
preprocessed version of the Emacs source code, not by trying to
implement them in Scheme. (Which, of course, is what Ken Raeburn's
project is already trying to do.)
Given this conclusion, I expect that most of the translator's Scheme
code will eventually become obsolete, replaced by bits of Emacs C
code. Until then, though, it should have a role:
- as a guide to the Guile Emacs project on how to interface to the
Elisp support in libguile (notably, usage of `@fop' and `@bind')
- as a proof of concept and fun thing to experiment with
- as a working translator that could help us develop our picture of
how we want to integrate translator usage in general with the rest
of Guile.

16
lang/elisp/base.scm
View file

@ -1,13 +1,12 @@
(define-module (lang elisp base)
;; Be pure. Nothing in this module requires most of the standard
;; Guile builtins, and it creates a problem if this module has
;; access to them, as @bind can dynamically change their values.
;; Be pure. Nothing in this module requires symbols that map to the
;; standard Guile builtins, and it creates a problem if this module
;; has access to them, as @bind can dynamically change their values.
;; Transformer output always uses the values of builtin procedures
;; and macros directly.
#:pure
;; But we do need a few builtins - import them here.
#:use-module ((guile) #:select (@fop @bind nil-cond))
;; {Elisp Primitives}
;;
;; In other words, Scheme definitions of elisp primitives. This
@ -34,13 +33,10 @@
;; Now switch into Emacs Lisp syntax.
#:use-syntax (lang elisp transform))
;(use-modules (lang elisp transform))
;(read-set! keywords 'prefix)
;(set-module-transformer! (current-module) transformer)
;;; Everything below here is written in Elisp.
(defun load-emacs ()
(scheme (read-set! keywords 'prefix))
(message "Calling loadup.el to clothe the bare Emacs...")
(load "loadup.el")
(message "Guile Emacs now fully clothed"))

29
lang/elisp/example.el
View file

@ -8,3 +8,32 @@
(apply 'concat contents)
"</BODY>\n"
"</HTML>\n"))
(defmacro time (repeat-count &rest body)
`(let ((count ,repeat-count)
(beg (current-time))
end)
(while (> count 0)
(setq count (- count 1))
,@body)
(setq end (current-time))
(+ (* 1000000.0 (+ (* 65536.0 (- (car end) (car beg)))
(- (cadr end) (cadr beg))))
(* 1.0 (- (caddr end) (caddr beg))))))
;Non-scientific performance measurements (Guile measurements are with
;`guile -q --no-debug'):
;
;(time 100000 (+ 3 4))
; => 225,071 (Emacs) 4,000,000 (Guile)
;(time 100000 (lambda () 1))
; => 2,410,456 (Emacs) 4,000,000 (Guile)
;(time 100000 (apply 'concat (mapcar (lambda (s) (concat s "." s)) '("a" "b" "c" "d"))))
; => 10,185,792 (Emacs) 136,000,000 (Guile)
;(defun sc (s) (concat s "." s))
;(time 100000 (apply 'concat (mapcar 'sc '("a" "b" "c" "d"))))
; => 7,870,055 (Emacs) 26,700,000 (Guile)
;
;Sadly, it looks like the translator's performance sucks quite badly
;when compared with Emacs. But the translator is still very new, so
;there's probably plenty of room of improvement.

8
lang/elisp/interface.scm
View file

@ -2,7 +2,9 @@
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals fset)
#:use-module ((lang elisp internals load) #:select ((load . elisp:load)))
#:use-module ((lang elisp transform) #:select (transformer))
#:export (eval-elisp
translate-elisp
elisp-function
elisp-variable
load-elisp-file
@ -19,6 +21,10 @@
"Evaluate the Elisp expression @var{x}."
(eval x the-elisp-module))
(define (translate-elisp x)
"Translate the Elisp expression @var{x} to equivalent Scheme code."
(transformer x))
(define (elisp-function sym)
"Return the procedure or macro that implements @var{sym} in Elisp.
If @var{sym} has no Elisp function definition, return @code{#f}."
@ -112,7 +118,7 @@ exported to Elisp."
(error "No macro name specified or deducible:" obj)))
((symbol? obj)
(or name
(set! name symbol))
(set! name obj))
(module-add! the-elisp-module name
(module-ref (current-module) obj)))
(else

46
lang/elisp/internals/lambda.scm
View file

@ -67,28 +67,28 @@
`(((,> %--num-args ,(+ num-required num-optional))
(,error "Wrong number of args (too many args)"))))
(else
(@bind ,(append (map (lambda (i)
(list (list-ref required i)
`(,list-ref %--args ,i)))
(iota num-required))
(map (lambda (i)
(let ((i+nr (+ i num-required)))
(list (list-ref optional i)
`(,if (,> %--num-args ,i+nr)
(,list-ref %--args ,i+nr)
#f))))
(iota num-optional))
(if rest
(list (list rest
`(,if (,> %--num-args
,(+ num-required
num-optional))
(,list-tail %--args
,(+ num-required
num-optional))
'())))
'()))
,@(map transformer (cddr exp)))))))))))
(, @bind ,(append (map (lambda (i)
(list (list-ref required i)
`(,list-ref %--args ,i)))
(iota num-required))
(map (lambda (i)
(let ((i+nr (+ i num-required)))
(list (list-ref optional i)
`(,if (,> %--num-args ,i+nr)
(,list-ref %--args ,i+nr)
,%nil))))
(iota num-optional))
(if rest
(list (list rest
`(,if (,> %--num-args
,(+ num-required
num-optional))
(,list-tail %--args
,(+ num-required
num-optional))
,%nil)))
'()))
,@(map transformer (cddr exp)))))))))))
(define (set-not-subr! proc boolean)
(set! (not-subr? proc) boolean))
@ -101,7 +101,7 @@
(,set-procedure-property! %--lambda (,quote name) (,quote ,name))
(,set-not-subr! %--lambda #t)
,@(if is
`((,set! (,interactive-spec %--lambda) (,quote ,is)))
`((,set! (,interactive-specification %--lambda) (,quote ,is)))
'())
%--lambda)))

14
lang/elisp/internals/null.scm
View file

@ -1,7 +1,13 @@
(define-module (lang elisp internals null)
#:export (null))
#:export (->nil lambda->nil null))
(define (->nil x)
(or x %nil))
(define (lambda->nil proc)
(lambda args
(->nil (apply proc args))))
(define (null obj)
(or (not obj)
(null? obj)
(eq? obj 'nil))) ; Should be removed.
(->nil (or (not obj)
(null? obj))))

3
lang/elisp/primitives/features.scm
View file

@ -1,6 +1,7 @@
(define-module (lang elisp primitives features)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals load)
#:use-module (lang elisp internals null)
#:use-module (ice-9 optargs))
(define-public features '())
@ -12,7 +13,7 @@
(fset 'featurep
(lambda (feature)
(memq feature features)))
(->nil (memq feature features))))
(fset 'require
(lambda* (feature #:optional file-name noerror)

6
lang/elisp/primitives/fns.scm
View file

@ -18,11 +18,11 @@
(fset 'commandp
(lambda (sym)
(if (interactive-spec (fref sym)) #t %nil)))
(if (interactive-specification (fref sym)) #t %nil)))
(fset 'fboundp
(lambda (sym)
(variable? (symbol-fref sym))))
(->nil (variable? (symbol-fref sym)))))
(fset 'symbol-function fref/error-if-void)
@ -30,7 +30,7 @@
(fset 'subrp
(lambda (obj)
(not (not-subr? obj))))
(->nil (not (not-subr? obj)))))
(fset 'byte-code-function-p
(lambda (object)

29
lang/elisp/primitives/lists.scm
View file

@ -3,9 +3,7 @@
#:use-module (lang elisp internals null)
#:use-module (lang elisp internals signal))
(fset 'cons
(lambda (x y)
(cons x (or y '()))))
(fset 'cons cons)
(fset 'null null)
@ -14,13 +12,13 @@
(fset 'car
(lambda (l)
(if (null l)
#f
%nil
(car l))))
(fset 'cdr
(lambda (l)
(if (null l)
#f
%nil
(cdr l))))
(fset 'eq
@ -35,12 +33,7 @@
(fset 'setcar set-car!)
(fset 'setcdr
(lambda (cell newcdr)
(set-cdr! cell
(if (null newcdr)
'()
newcdr))))
(fset 'setcdr set-cdr!)
(for-each (lambda (sym proc)
(fset sym
@ -48,14 +41,10 @@
(if (null list)
%nil
(if (null elt)
(or (proc #f list)
(proc '() list)
(proc %nil list)
(proc 'nil list)) ; 'nil shouldn't be
; here, as it should
; have been
; translated by the
; transformer.
(let loop ((l list))
(cond ((null l) %nil)
((null (car l)) l)
(else (loop (cdr l)))))
(proc elt list))))))
'( memq member assq assoc)
`(,memq ,member ,assq ,assoc))
@ -97,7 +86,7 @@
(lambda (n list)
(if (or (null list)
(>= n (length list)))
#f
%nil
(list-ref list n))))
(fset 'listp

2
lang/elisp/primitives/load.scm
View file

@ -14,4 +14,4 @@
(lambda args
#t))
(define-public current-load-list #f)
(define-public current-load-list %nil)

2
lang/elisp/primitives/match.scm
View file

@ -45,7 +45,7 @@
(iota (match:count match))))
#f)))
(if last-match (car last-match) #f)))
(if last-match (car last-match) %nil)))
(fset 'match-beginning
(lambda (subexp)

7
lang/elisp/primitives/numbers.scm
View file

@ -1,9 +1,10 @@
(define-module (lang elisp primitives numbers)
#:use-module (lang elisp internals fset))
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals null))
(fset 'logior logior)
(fset 'logand logand)
(fset 'integerp integer?)
(fset 'integerp (lambda->nil integer?))
(fset '= =)
(fset '< <)
(fset '> >)
@ -39,4 +40,4 @@
(- shift 1))))))
lsh))
(fset 'numberp number?)
(fset 'numberp (lambda->nil number?))

2
lang/elisp/primitives/pure.scm
View file

@ -5,4 +5,4 @@
(fset 'purecopy identity)
(define-public purify-flag #f)
(define-public purify-flag %nil)

5
lang/elisp/primitives/strings.scm
View file

@ -1,5 +1,6 @@
(define-module (lang elisp primitives strings)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals null)
#:use-module (lang elisp internals signal))
(fset 'substring substring)
@ -19,7 +20,7 @@
(fset 'number-to-string number->string)
(fset 'string-lessp string<?)
(fset 'string-lessp (lambda->nil string<?))
(fset 'string< 'string-lessp)
(fset 'aref
@ -28,6 +29,6 @@
((string? array) (char->integer (string-ref array idx)))
(else (wta 'arrayp array 1)))))
(fset 'stringp string?)
(fset 'stringp (lambda->nil string?))
(fset 'vector vector)

12
lang/elisp/primitives/symprop.scm
View file

@ -1,7 +1,8 @@
(define-module (lang elisp primitives symprop)
#:use-module (lang elisp internals set)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals null)
#:use-module (lang elisp internals set)
#:use-module (ice-9 optargs))
;;; {Elisp Exports}
@ -16,7 +17,7 @@
(fset 'boundp
(lambda (sym)
(module-defined? the-elisp-module sym)))
(->nil (module-defined? the-elisp-module sym))))
(fset 'default-boundp 'boundp)
@ -29,10 +30,11 @@
(fset 'symbolp
(lambda (object)
(or (symbol? object)
(keyword? object))))
(keyword? object)
%nil)))
(fset 'local-variable-if-set-p
(lambda* (variable #:optional buffer)
#f))
%nil))
(fset 'symbol-name symbol->string)

118
lang/elisp/primitives/syntax.scm
View file

@ -32,7 +32,6 @@
`(,quote ,(cadr exp))
`(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
,(setq (list (car exp) (cadr exp) (caddr exp)) env))
;; (,macro-setq ,(cadr exp) ,(caddr exp)))
(,quote ,(cadr exp)))))))
(fset 'defconst
@ -87,28 +86,28 @@
`(((,> %--num-args ,(+ num-required num-optional))
(,error "Wrong number of args (too many args)"))))
(else (,transformer
(@bind ,(append (map (lambda (i)
(list (list-ref required i)
`(,list-ref %--args ,i)))
(iota num-required))
(map (lambda (i)
(let ((i+nr (+ i num-required)))
(list (list-ref optional i)
`(,if (,> %--num-args ,i+nr)
(,list-ref %--args ,i+nr)
#f))))
(iota num-optional))
(if rest
(list (list rest
`(,if (,> %--num-args
,(+ num-required
num-optional))
(,list-tail %--args
,(+ num-required
num-optional))
'())))
'()))
,@(map transformer (cdddr exp)))))))))))))))))
(, @bind ,(append (map (lambda (i)
(list (list-ref required i)
`(,list-ref %--args ,i)))
(iota num-required))
(map (lambda (i)
(let ((i+nr (+ i num-required)))
(list (list-ref optional i)
`(,if (,> %--num-args ,i+nr)
(,list-ref %--args ,i+nr)
,%nil))))
(iota num-optional))
(if rest
(list (list rest
`(,if (,> %--num-args
,(+ num-required
num-optional))
(,list-tail %--args
,(+ num-required
num-optional))
,%nil)))
'()))
,@(map transformer (cdddr exp)))))))))))))))))
;;; {Sequencing}
@ -120,36 +119,34 @@
(fset 'prog1
(procedure->memoizing-macro
(lambda (exp env)
`(,let ((%res1 ,(transformer (cadr exp))))
`(,let ((%--res1 ,(transformer (cadr exp))))
,@(map transformer (cddr exp))
%res1))))
%--res1))))
(fset 'prog2
(procedure->memoizing-macro
(lambda (exp env)
`(,begin ,(transformer (cadr exp))
(,let ((%res2 ,(transformer (caddr exp))))
(,let ((%--res2 ,(transformer (caddr exp))))
,@(map transformer (cdddr exp))
%res2)))))
%--res2)))))
;;; {Conditionals}
(define <-- *unspecified*)
(fset 'if
(procedure->memoizing-macro
(lambda (exp env)
(let ((else-case (cdddr exp)))
(cond ((null? else-case)
`(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f))
`(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil))
((null? (cdr else-case))
`(nil-cond ,(transformer (cadr exp))
,(transformer (caddr exp))
,(transformer (car else-case))))
`(,nil-cond ,(transformer (cadr exp))
,(transformer (caddr exp))
,(transformer (car else-case))))
(else
`(nil-cond ,(transformer (cadr exp))
,(transformer (caddr exp))
(,begin ,@(map transformer else-case)))))))))
`(,nil-cond ,(transformer (cadr exp))
,(transformer (caddr exp))
(,begin ,@(map transformer else-case)))))))))
(fset 'and
(procedure->memoizing-macro
@ -162,13 +159,26 @@
(if (null? (cdr args))
(list (transformer (car args)))
(cons (list not (transformer (car args)))
(cons #f
(cons %nil
(loop (cdr args))))))))))))
;;; NIL-COND expressions have the form:
;;;
;;; (nil-cond COND VAL COND VAL ... ELSEVAL)
;;;
;;; The CONDs are evaluated in order until one of them returns true
;;; (in the Elisp sense, so not including empty lists). If a COND
;;; returns true, its corresponding VAL is evaluated and returned,
;;; except if that VAL is the unspecified value, in which case the
;;; result of evaluating the COND is returned. If none of the COND's
;;; returns true, ELSEVAL is evaluated and its value returned.
(define <-- *unspecified*)
(fset 'or
(procedure->memoizing-macro
(lambda (exp env)
(cond ((null? (cdr exp)) #f)
(cond ((null? (cdr exp)) %nil)
((null? (cddr exp)) (transformer (cadr exp)))
(else
(cons nil-cond
@ -183,15 +193,15 @@
(procedure->memoizing-macro
(lambda (exp env)
(if (null? (cdr exp))
#f
%nil
(cons
nil-cond
(let loop ((clauses (cdr exp)))
(if (null? clauses)
'(#f)
(list %nil)
(let ((clause (car clauses)))
(if (eq? (car clause) #t)
(cond ((null? (cdr clause)) '(t))
(cond ((null? (cdr clause)) (list #t))
((null? (cddr clause))
(list (transformer (cadr clause))))
(else `((,begin ,@(map transformer (cdr clause))))))
@ -210,7 +220,7 @@
(,nil-cond ,(transformer (cadr exp))
(,begin ,@(map transformer (cddr exp))
(%--while))
#f))))
,%nil))))
%--while)))))
;;; {Local binding}
@ -218,13 +228,13 @@
(fset 'let
(procedure->memoizing-macro
(lambda (exp env)
`(@bind ,(map (lambda (binding)
(trc 'let binding)
(if (pair? binding)
`(,(car binding) ,(transformer (cadr binding)))
`(,binding #f)))
(cadr exp))
,@(map transformer (cddr exp))))))
`(, @bind ,(map (lambda (binding)
(trc 'let binding)
(if (pair? binding)
`(,(car binding) ,(transformer (cadr binding)))
`(,binding ,%nil)))
(cadr exp))
,@(map transformer (cddr exp))))))
(fset 'let*
(procedure->memoizing-macro
@ -234,11 +244,11 @@
(car (let loop ((bindings (cadr exp)))
(if (null? bindings)
(map transformer (cddr exp))
`((@bind (,(let ((binding (car bindings)))
(if (pair? binding)
`(,(car binding) ,(transformer (cadr binding)))
`(,binding #f))))
,@(loop (cdr bindings)))))))))))
`((, @bind (,(let ((binding (car bindings)))
(if (pair? binding)
`(,(car binding) ,(transformer (cadr binding)))
`(,binding ,%nil))))
,@(loop (cdr bindings)))))))))))
;;; {Exception handling}

125
lang/elisp/transform.scm
View file

@ -5,81 +5,98 @@
#:use-module (ice-9 session)
#:export (transformer transform))
;;; {S-expressions}
;;; 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))
;; Should be made mutating instead of constructing
;;
(define-macro (scheme exp . module)
(let ((m (resolve-module (if (null? module)
'(guile-user)
(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)
((null? x) %nil)
((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))))
;; Could add other translations here, notably `?A' -> 65 etc.
(else x)))
(define (m-quasiquote exp env)
(cons quasiquote
(map transform-inside-qq (cdr exp))))
(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-inside-qq x)
(trc 'transform-inside-qq x)
(cond ((not (pair? x)) 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 (car x) (map transform-inside-qq (cdr x))))))
(else (cons-source x
(transform-datum (car x))
(transform-quasiquote (cdr x))))))
(else
(cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x))))))
(cons-source x
(transform-quasiquote (car x))
(transform-quasiquote (cdr x))))))
(define (transform-application x)
(cons-source x
'@fop
`(,(car x) (,transformer-macro ,@(cdr 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 '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))))))
(cons-source exp list (map transformer (cdr exp)))))))
(define transform transformer)