1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-18 10:10:23 +02:00

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.
This commit is contained in:
Brian Templeton 2010-07-09 19:52:48 -04:00
parent 1d7a1b8e0f
commit 7d6816f0c7
4 changed files with 315 additions and 216 deletions

View file

@ -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.
;;; Special operators
(define (compile-symbol loc sym)
(case sym
((nil) (nil-value loc))
((t) (t-value loc))
(else (reference-with-check loc sym value-slot))))
(defspecial progn (loc args)
(make-sequence loc (map compile-expr args)))
;;; 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)
(defspecial if (loc args)
(pmatch args
((,cond ,then . ,else)
(make-conditional loc
(compile-expr condition)
(compile-expr ifclause)
(nil-value loc)))
(compile-expr cond)
(compile-expr then)
(if (null? else)
(nil-value loc)
(make-sequence loc
(map compile-expr else)))))))
((if ,condition ,ifclause ,elseclause)
(make-conditional loc
(compile-expr condition)
(compile-expr ifclause)
(compile-expr elseclause)))
((if ,condition ,ifclause . ,elses)
(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)
(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,13 +691,9 @@
(reference-variable loc sym value-slot))
(set-variable! loc sym value-slot (compile-expr value))
(make-void loc))
(make-const loc sym)))))
(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)))
(defspecial setq (loc args)
(make-sequence
loc
(let iterate ((tail args))
@ -733,76 +725,83 @@
(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.
(defspecial let (loc args)
(pmatch args
((,bindings . ,body)
(generate-let loc value-slot bindings body))))
((let ,bindings . ,body) (guard (and (list? bindings)
(not (null? bindings))
(not (null? body))))
(generate-let loc value-slot bindings body))
(defspecial lexical-let (loc args)
(pmatch args
((,bindings . ,body)
(generate-let loc 'lexical bindings body))))
((lexical-let ,bindings . ,body) (guard (and (list? bindings)
(not (null? bindings))
(not (null? body))))
(generate-let loc 'lexical bindings body))
(defspecial flet (loc args)
(pmatch args
((,bindings . ,body)
(generate-let loc function-slot bindings body))))
((flet ,bindings . ,body) (guard (and (list? bindings)
(not (null? bindings))
(not (null? body))))
(generate-let loc function-slot bindings body))
(defspecial let* (loc args)
(pmatch args
((,bindings . ,body)
(generate-let* loc value-slot bindings body))))
((let* ,bindings . ,body) (guard (and (list? bindings)
(not (null? bindings))
(not (null? body))))
(generate-let* loc value-slot bindings body))
(defspecial lexical-let* (loc args)
(pmatch args
((,bindings . ,body)
(generate-let* loc 'lexical bindings body))))
((lexical-let* ,bindings . ,body) (guard (and (list? bindings)
(not (null? bindings))
(not (null? body))))
(generate-let* loc 'lexical bindings body))
(defspecial flet* (loc args)
(pmatch args
((,bindings . ,body)
(generate-let* loc function-slot 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.
;; 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))))
((without-void-checks ,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))))
((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 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-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 allows to create primitive references, which are
;; still a little faster.
(defspecial guile-primitive (loc args)
(pmatch args
((,sym)
(make-primitive-ref loc sym))))
((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.
;; 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)
(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)))
iter-call)))))
;; Either (lambda ...) or (function (lambda ...)) denotes a
;; lambda-expression that should be compiled.
(defspecial function (loc args)
(pmatch args
(((lambda ,args . ,body))
(compile-lambda loc args body))))
((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.
((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)))))
((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)))
tree-il)))))
;; XXX: Maybe we could implement backquotes in macros, too.
(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)))))))
((,backq ,val) (guard (backquote? backq))
(process-backquote loc val))
(defspecial \` (loc args)
(pmatch args
((,val)
(process-backquote loc val))))
;; XXX: Why do we need 'quote here instead of quote?
(defspecial quote (loc args)
(pmatch args
((,val)
(make-const loc val))))
(('quote ,val)
(make-const loc val))
;; Macro calls are simply expanded and recursively compiled.
((,macro . ,args) (guard (is-macro? macro))
(compile-expr (apply (get-macro macro) args)))
;; 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.
((,func . ,args)
(make-application loc
(if (symbol? func)
(reference-with-check loc func function-slot)
(compile-expr func))
(map compile-expr args)))
;;; Compile a compound expression to Tree-IL.
(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
(report-error loc "unrecognized elisp" expr))))
(make-application loc
(if (symbol? operator)
(reference-with-check loc
operator
function-slot)
(compile-expr operator))
(map compile-expr arguments))))))
;;; 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 single expression to TreeIL.

View file

@ -32,7 +32,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.
@ -110,10 +110,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 ()
(lambda (x)
(syntax-case x ()
((_ name value)
(define-public name (cons 'macro 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.

View file

@ -19,8 +19,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
@ -83,18 +158,4 @@
throw
not
eval
load)
;; macros
#:re-export (prog1
prog2
when
unless
cond
and
or
dotimes
dolist
catch
unwind-protect
pop
push))
load))

View file

@ -27,6 +27,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.