diff options
author | Brian Templeton <bpt@hcoop.net> | 2010-07-09 19:52:48 -0400 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-12-07 13:21:02 +0100 |
commit | 44ae163d2c469c62352cbce7dbb3542b421a2f8d (patch) | |
tree | 92c0b8b81d68292b7847b0c15e04b5ce2bf5706a | |
parent | e9de35293f237081365879e1e637267b5eb058b6 (diff) | |
download | guile-44ae163d2c469c62352cbce7dbb3542b421a2f8d.tar.gz |
store special operators in the function slot
If the function slot of a symbol contains a pair with `special-operator'
in the car and a procedure in the cdr, the procedure is called to
compile the form to Tree-IL. This is similar to other Emacs Lisp
implementations, in which special operators are subrs.
* module/language/elisp/compile-tree-il.scm: Restructured to store
special operator definitions in the function slot. Import `(language
elisp runtime)' for `defspecial'. Export special operators so that
`(language elisp runtime function-slot)' can re-export them.
(backquote?): Removed; the backquote symbol is defined as a special
operator, so it's no longer used in `compile-pair'.
(is-macro?, get-macro): Replaced by `find-operator'.
(find-operator): New procedure.
(compile-progn, compile-if, compile-defconst, compile-defvar,
compile-setq, compile-let, compile-lexical-let, compile-flet,
compile-let*, compile-lexical-let*, compile-flet*,
compile-without-void-checks, compile-with-always-lexical,
compile-guile-ref, compile-guile-primitive, compile-while,
compile-function, compile-defmacro, compile-defun, #{compile-`}#,
compile-quote): New special operators with definitions taken from the
pmatch form in `compile-pair'. There is no special operator `lambda';
it is now a macro, as in other Elisp implementations.
(compile-pair): Instead of directly compiling special forms, check for
a special operator object in the function slot.
* module/language/elisp/runtime.scm: Export `defspecial'.
(make-id): New function.
(built-in-macro): Prefix macros with `macro-'.
(defspecial): New syntax.
* module/language/elisp/runtime/function-slot.scm: Import and re-export
special operators. Rename imported special operators and macros to
remove prefixes. Re-export new macro `lambda'.
* module/language/elisp/runtime/macros.scm (macro-lambda): New Elisp
macro.
-rw-r--r-- | module/language/elisp/compile-tree-il.scm | 431 | ||||
-rw-r--r-- | module/language/elisp/runtime.scm | 37 | ||||
-rw-r--r-- | module/language/elisp/runtime/function-slot.scm | 93 | ||||
-rw-r--r-- | module/language/elisp/runtime/macros.scm | 4 |
4 files changed, 332 insertions, 233 deletions
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index b99fcc11e..cb2271a41 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -21,6 +21,7 @@ (define-module (language elisp compile-tree-il) #:use-module (language elisp bindings) + #:use-module (language elisp runtime) #:use-module (language tree-il) #:use-module (system base pmatch) #:use-module (system base compile) @@ -28,7 +29,28 @@ #:use-module (srfi srfi-8) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:export (compile-tree-il)) + #:export (compile-tree-il + compile-progn + compile-if + compile-defconst + compile-defvar + compile-setq + compile-let + compile-lexical-let + compile-flet + compile-let* + compile-lexical-let* + compile-flet* + compile-without-void-checks + compile-with-always-lexical + compile-guile-ref + compile-guile-primitive + compile-while + compile-function + compile-defmacro + compile-defun + compile-\` + compile-quote)) ;;; Certain common parameters (like the bindings data structure or ;;; compiler options) are not always passed around but accessed using @@ -78,9 +100,6 @@ ;;; predicates checking for a symbol being the car of an ;;; unquote/unquote-splicing/backquote form. -(define (backquote? sym) - (and (symbol? sym) (eq? sym '\`))) - (define (unquote? sym) (and (symbol? sym) (eq? sym '\,))) @@ -546,21 +565,17 @@ ;; TODO: Handle doc string if present. (else #t))) -;;; Handle macro bindings. +;;; Handle macro and special operator bindings. -(define (is-macro? sym) +(define (find-operator sym type) (and (symbol? sym) (module-defined? (resolve-interface function-slot) sym) - (let* ((macro (module-ref (resolve-module function-slot) sym)) - (macro (if (fluid? macro) (fluid-ref macro) macro))) - (and (pair? macro) (eq? (car macro) 'macro))))) - -(define (get-macro sym) - (and - (is-macro? sym) - (let ((macro (module-ref (resolve-module function-slot) sym))) - (cdr (if (fluid? macro) (fluid-ref macro) macro))))) + (let* ((op (module-ref (resolve-module function-slot) sym)) + (op (if (fluid? op) (fluid-ref op) op))) + (if (and (pair? op) (eq? (car op) type)) + (cdr op) + #f)))) ;;; See if a (backquoted) expression contains any unquotes. @@ -634,56 +649,37 @@ (with-fluids ((fluid new)) (make-body)))))) -;;; Compile a symbol expression. This is a variable reference or maybe -;;; some special value like nil. - -(define (compile-symbol loc sym) - (case sym - ((nil) (nil-value loc)) - ((t) (t-value loc)) - (else (reference-with-check loc sym value-slot)))) - -;;; Compile a pair-expression (that is, any structure-like construct). - -(define (compile-pair loc expr) - (pmatch expr - ((progn . ,forms) - (make-sequence loc (map compile-expr forms))) - - ((if ,condition ,ifclause) - (make-conditional loc - (compile-expr condition) - (compile-expr ifclause) - (nil-value loc))) +;;; Special operators - ((if ,condition ,ifclause ,elseclause) - (make-conditional loc - (compile-expr condition) - (compile-expr ifclause) - (compile-expr elseclause))) +(defspecial progn (loc args) + (make-sequence loc (map compile-expr args))) - ((if ,condition ,ifclause . ,elses) +(defspecial if (loc args) + (pmatch args + ((,cond ,then . ,else) (make-conditional loc - (compile-expr condition) - (compile-expr ifclause) - (make-sequence loc (map compile-expr elses)))) - - ;; defconst and defvar are kept here in the compiler (rather than - ;; doing them as macros) for if we may want to handle the docstring - ;; somehow. - - ((defconst ,sym ,value . ,doc) + (compile-expr cond) + (compile-expr then) + (if (null? else) + (nil-value loc) + (make-sequence loc + (map compile-expr else))))))) + +(defspecial defconst (loc args) + (pmatch args + ((,sym ,value . ,doc) (if (handle-var-def loc sym doc) (make-sequence loc (list (set-variable! loc sym value-slot (compile-expr value)) - (make-const loc sym))))) + (make-const loc sym))))))) - ((defvar ,sym) (make-const loc sym)) - - ((defvar ,sym ,value . ,doc) +(defspecial defvar (loc args) + (pmatch args + ((,sym) (make-const loc sym)) + ((,sym ,value . ,doc) (if (handle-var-def loc sym doc) (make-sequence loc @@ -695,114 +691,117 @@ (reference-variable loc sym value-slot)) (set-variable! loc sym value-slot (compile-expr value)) (make-void loc)) - (make-const loc sym))))) - - ;; Build a set form for possibly multiple values. The code is not - ;; formulated tail recursive because it is clearer this way and - ;; large lists of symbol expression pairs are very unlikely. - - ((setq . ,args) (guard (not (null? args))) - (make-sequence - loc - (let iterate ((tail args)) - (let ((sym (car tail)) - (tailtail (cdr tail))) - (if (not (symbol? sym)) - (report-error loc "expected symbol in setq") - (if (null? tailtail) - (report-error loc - "missing value for symbol in setq" - sym) - (let* ((val (compile-expr (car tailtail))) - (op (set-variable! loc sym value-slot val))) - (if (null? (cdr tailtail)) - (let* ((temp (gensym)) - (ref (make-lexical-ref loc temp temp))) - (list (make-let - loc - `(,temp) - `(,temp) - `(,val) - (make-sequence - loc - (list (set-variable! loc - sym - value-slot - ref) - ref))))) - (cons (set-variable! loc sym value-slot val) - (iterate (cdr tailtail))))))))))) - - ;; All lets (let, flet, lexical-let and let* forms) are done using - ;; the generate-let/generate-let* methods. - - ((let ,bindings . ,body) (guard (and (list? bindings) - (not (null? bindings)) - (not (null? body)))) - (generate-let loc value-slot bindings body)) - - ((lexical-let ,bindings . ,body) (guard (and (list? bindings) - (not (null? bindings)) - (not (null? body)))) - (generate-let loc 'lexical bindings body)) - - ((flet ,bindings . ,body) (guard (and (list? bindings) - (not (null? bindings)) - (not (null? body)))) - (generate-let loc function-slot bindings body)) - - ((let* ,bindings . ,body) (guard (and (list? bindings) - (not (null? bindings)) - (not (null? body)))) - (generate-let* loc value-slot bindings body)) - - ((lexical-let* ,bindings . ,body) (guard (and (list? bindings) - (not (null? bindings)) - (not (null? body)))) - (generate-let* loc 'lexical bindings body)) - - ((flet* ,bindings . ,body) (guard (and (list? bindings) - (not (null? bindings)) - (not (null? body)))) - (generate-let* loc function-slot bindings body)) - - ;; Temporarily disable void checks or set symbols as always lexical - ;; only for the lexical scope of a construct. - - ((without-void-checks ,syms . ,body) - (with-added-symbols loc disable-void-check syms body)) - - ((with-always-lexical ,syms . ,body) - (with-added-symbols loc always-lexical syms body)) - - ;; guile-ref allows building TreeIL's module references from within - ;; elisp as a way to access data within the Guile universe. The - ;; module and symbol referenced are static values, just like (@ - ;; module symbol) does! - - ((guile-ref ,module ,sym) (guard (and (list? module) (symbol? sym))) - (make-module-ref loc module sym #t)) - - ;; guile-primitive allows to create primitive references, which are - ;; still a little faster. - - ((guile-primitive ,sym) (guard (symbol? sym)) - (make-primitive-ref loc sym)) - - ;; A while construct is transformed into a tail-recursive loop like - ;; this: - ;; - ;; (letrec ((iterate (lambda () - ;; (if condition - ;; (begin body - ;; (iterate)) - ;; #nil)))) - ;; (iterate)) - ;; - ;; As letrec is not directly accessible from elisp, while is - ;; implemented here instead of with a macro. - - ((while ,condition . ,body) + (make-const loc sym))))))) + +(defspecial setq (loc args) + (make-sequence + loc + (let iterate ((tail args)) + (let ((sym (car tail)) + (tailtail (cdr tail))) + (if (not (symbol? sym)) + (report-error loc "expected symbol in setq") + (if (null? tailtail) + (report-error loc + "missing value for symbol in setq" + sym) + (let* ((val (compile-expr (car tailtail))) + (op (set-variable! loc sym value-slot val))) + (if (null? (cdr tailtail)) + (let* ((temp (gensym)) + (ref (make-lexical-ref loc temp temp))) + (list (make-let + loc + `(,temp) + `(,temp) + `(,val) + (make-sequence + loc + (list (set-variable! loc + sym + value-slot + ref) + ref))))) + (cons (set-variable! loc sym value-slot val) + (iterate (cdr tailtail))))))))))) + +(defspecial let (loc args) + (pmatch args + ((,bindings . ,body) + (generate-let loc value-slot bindings body)))) + +(defspecial lexical-let (loc args) + (pmatch args + ((,bindings . ,body) + (generate-let loc 'lexical bindings body)))) + +(defspecial flet (loc args) + (pmatch args + ((,bindings . ,body) + (generate-let loc function-slot bindings body)))) + +(defspecial let* (loc args) + (pmatch args + ((,bindings . ,body) + (generate-let* loc value-slot bindings body)))) + +(defspecial lexical-let* (loc args) + (pmatch args + ((,bindings . ,body) + (generate-let* loc 'lexical bindings body)))) + +(defspecial flet* (loc args) + (pmatch args + ((,bindings . ,body) + (generate-let* loc function-slot bindings body)))) + +;;; Temporarily disable void checks or set symbols as always lexical +;;; only for the lexical scope of a construct. + +(defspecial without-void-checks (loc args) + (pmatch args + ((,syms . ,body) + (with-added-symbols loc disable-void-check syms body)))) + +(defspecial with-always-lexical (loc args) + (pmatch args + ((,syms . ,body) + (with-added-symbols loc always-lexical syms body)))) + +;;; guile-ref allows building TreeIL's module references from within +;;; elisp as a way to access data within the Guile universe. The module +;;; and symbol referenced are static values, just like (@ module symbol) +;;; does! + +(defspecial guile-ref (loc args) + (pmatch args + ((,module ,sym) (guard (and (list? module) (symbol? sym))) + (make-module-ref loc module sym #t)))) + +;;; guile-primitive allows to create primitive references, which are +;;; still a little faster. + +(defspecial guile-primitive (loc args) + (pmatch args + ((,sym) + (make-primitive-ref loc sym)))) + +;;; A while construct is transformed into a tail-recursive loop like +;;; this: +;;; +;;; (letrec ((iterate (lambda () +;;; (if condition +;;; (begin body +;;; (iterate)) +;;; #nil)))) +;;; (iterate)) +;;; +;;; As letrec is not directly accessible from elisp, while is +;;; implemented here instead of with a macro. + +(defspecial while (loc args) + (pmatch args + ((,condition . ,body) (let* ((itersym (gensym)) (compiled-body (map compile-expr body)) (iter-call (make-application loc @@ -832,34 +831,16 @@ '(iterate) (list itersym) (list iter-thunk) - iter-call))) - - ;; Either (lambda ...) or (function (lambda ...)) denotes a - ;; lambda-expression that should be compiled. - - ((lambda ,args . ,body) - (compile-lambda loc args body)) - - ((function (lambda ,args . ,body)) - (compile-lambda loc args body)) - - ;; Build a lambda and also assign it to the function cell of some - ;; symbol. This is no macro as we might want to honour the docstring - ;; at some time; just as with defvar/defconst. + iter-call))))) - ((defun ,name ,args . ,body) - (if (not (symbol? name)) - (report-error loc "expected symbol as function name" name) - (make-sequence loc - (list (set-variable! loc - name - function-slot - (compile-lambda loc - args - body)) - (make-const loc name))))) +(defspecial function (loc args) + (pmatch args + (((lambda ,args . ,body)) + (compile-lambda loc args body)))) - ((defmacro ,name ,args . ,body) +(defspecial defmacro (loc args) + (pmatch args + ((,name ,args . ,body) (if (not (symbol? name)) (report-error loc "expected symbol as macro name" name) (let* ((tree-il @@ -879,37 +860,61 @@ (compile (ensuring-globals loc bindings-data tree-il) #:from 'tree-il #:to 'value) - tree-il))) - - ;; XXX: Maybe we could implement backquotes in macros, too. + tree-il))))) - ((,backq ,val) (guard (backquote? backq)) - (process-backquote loc val)) - - ;; XXX: Why do we need 'quote here instead of quote? +(defspecial defun (loc args) + (pmatch args + ((,name ,args . ,body) + (if (not (symbol? name)) + (report-error loc "expected symbol as function name" name) + (make-sequence loc + (list (set-variable! loc + name + function-slot + (compile-lambda loc + args + body)) + (make-const loc name))))))) - (('quote ,val) - (make-const loc val)) +(defspecial \` (loc args) + (pmatch args + ((,val) + (process-backquote loc val)))) - ;; Macro calls are simply expanded and recursively compiled. +(defspecial quote (loc args) + (pmatch args + ((,val) + (make-const loc val)))) - ((,macro . ,args) (guard (is-macro? macro)) - (compile-expr (apply (get-macro macro) args))) +;;; Compile a compound expression to Tree-IL. - ;; Function calls using (function args) standard notation; here, we - ;; have to take the function value of a symbol if it is one. It - ;; seems that functions in form of uncompiled lists are not - ;; supported in this syntax, so we don't have to care for them. +(define (compile-pair loc expr) + (let ((operator (car expr)) + (arguments (cdr expr))) + (cond + ((find-operator operator 'special-operator) + => (lambda (special-operator-function) + (special-operator-function loc arguments))) + ((find-operator operator 'macro) + => (lambda (macro-function) + (compile-expr (apply macro-function arguments)))) + (else + (make-application loc + (if (symbol? operator) + (reference-with-check loc + operator + function-slot) + (compile-expr operator)) + (map compile-expr arguments)))))) - ((,func . ,args) - (make-application loc - (if (symbol? func) - (reference-with-check loc func function-slot) - (compile-expr func)) - (map compile-expr args))) +;;; Compile a symbol expression. This is a variable reference or maybe +;;; some special value like nil. - (else - (report-error loc "unrecognized elisp" expr)))) +(define (compile-symbol loc sym) + (case sym + ((nil) (nil-value loc)) + ((t) (t-value loc)) + (else (reference-with-check loc sym value-slot)))) ;;; Compile a single expression to TreeIL. diff --git a/module/language/elisp/runtime.scm b/module/language/elisp/runtime.scm index 5d4f63473..d8ca50232 100644 --- a/module/language/elisp/runtime.scm +++ b/module/language/elisp/runtime.scm @@ -31,7 +31,7 @@ set-variable! runtime-error macro-error) - #:export-syntax (built-in-func built-in-macro prim)) + #:export-syntax (built-in-func built-in-macro defspecial prim)) ;;; This module provides runtime support for the Elisp front-end. @@ -111,10 +111,39 @@ (define-public name (make-fluid)) (fluid-set! name value))))) +(define (make-id template-id . data) + (let ((append-symbols + (lambda (symbols) + (string->symbol + (apply string-append (map symbol->string symbols)))))) + (datum->syntax template-id + (append-symbols + (map (lambda (datum) + ((if (identifier? datum) + syntax->datum + identity) + datum)) + data))))) + (define-syntax built-in-macro - (syntax-rules () - ((_ name value) - (define-public name (cons 'macro value))))) + (lambda (x) + (syntax-case x () + ((_ name value) + (with-syntax ((scheme-name (make-id #'name 'macro- #'name))) + #'(begin + (define-public scheme-name (make-fluid)) + (fluid-set! scheme-name (cons 'macro value)))))))) + +(define-syntax defspecial + (lambda (x) + (syntax-case x () + ((_ name args body ...) + (with-syntax ((scheme-name (make-id #'name 'compile- #'name))) + #'(begin + (define scheme-name (make-fluid)) + (fluid-set! scheme-name + (cons 'special-operator + (lambda args body ...))))))))) ;;; Call a guile-primitive that may be rebound for elisp and thus needs ;;; absolute addressing. diff --git a/module/language/elisp/runtime/function-slot.scm b/module/language/elisp/runtime/function-slot.scm index ee68fe7d5..19ef351da 100644 --- a/module/language/elisp/runtime/function-slot.scm +++ b/module/language/elisp/runtime/function-slot.scm @@ -18,8 +18,83 @@ (define-module (language elisp runtime function-slot) #:use-module (language elisp runtime subrs) - #:use-module (language elisp runtime macros) + #:use-module ((language elisp runtime macros) + #:select + ((macro-lambda . lambda) + (macro-prog1 . prog1) + (macro-prog2 . prog2) + (macro-when . when) + (macro-unless . unless) + (macro-cond . cond) + (macro-and . and) + (macro-or . or) + (macro-dotimes . dotimes) + (macro-dolist . dolist) + (macro-catch . catch) + (macro-unwind-protect . unwind-protect) + (macro-pop . pop) + (macro-push . push))) + #:use-module ((language elisp compile-tree-il) + #:select + ((compile-progn . progn) + (compile-if . if) + (compile-defconst . defconst) + (compile-defvar . defvar) + (compile-setq . setq) + (compile-let . let) + (compile-lexical-let . lexical-let) + (compile-flet . flet) + (compile-let* . let*) + (compile-lexical-let* . lexical-let*) + (compile-flet* . flet*) + (compile-without-void-checks . without-void-checks) + (compile-with-always-lexical . with-always-lexical) + (compile-guile-ref . guile-ref) + (compile-guile-primitive . guile-primitive) + (compile-while . while) + (compile-function . function) + (compile-defun . defun) + (compile-defmacro . defmacro) + (compile-\` . \`) + (compile-quote . quote))) #:duplicates (last) + ;; special operators + #:re-export (progn + if + defconst + defvar + setq + let + lexical-let + flet + let* + lexical-let* + flet* + without-void-checks + with-always-lexical + guile-ref + guile-primitive + while + function + defun + defmacro + \` + quote) + ;; macros + #:re-export (lambda + prog1 + prog2 + when + unless + cond + and + or + dotimes + dolist + catch + unwind-protect + pop + push) ;; functions #:re-export (eq equal @@ -82,18 +157,4 @@ throw not eval - load) - ;; macros - #:re-export (prog1 - prog2 - when - unless - cond - and - or - dotimes - dolist - catch - unwind-protect - pop - push)) + load)) diff --git a/module/language/elisp/runtime/macros.scm b/module/language/elisp/runtime/macros.scm index 86b1ed2a8..6ab8852ba 100644 --- a/module/language/elisp/runtime/macros.scm +++ b/module/language/elisp/runtime/macros.scm @@ -26,6 +26,10 @@ ;;; during compilation, of course, so not really in runtime. But I ;;; think it fits well to the others here. +(built-in-macro lambda + (lambda cdr + `(function (lambda ,@cdr)))) + ;;; The prog1 and prog2 constructs can easily be defined as macros using ;;; progn and some lexical-let's to save the intermediate value to ;;; return at the end. |