mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
rewrite elisp macros in elisp
* module/language/elisp/runtime/macros.scm: Remove. (macro-lambda, macro-prog1, macro-prog2, macro-cond, macro-and, macro-or, macro-catch, macro-unwind-protect): Rewrite in Elisp and move to... * module/language/elisp/boot.el (lambda, prog1, prog2, cond, and, or, catch, unwind-protect): ...here. (eval-and-compile): New macro. (funcall, fset, null, consp, listp, car, cdr, make-symbol-signal): Wrap definitions in an `eval-and-compile' form so that they can be used by the rewritten macros. * module/language/elisp/runtime.scm: Remove `built-in-macro'. * module/language/elisp/Makefile.am: Remove module/language/elisp/runtime/macros.scm from `ELISP_LANG_SOURCES'.
This commit is contained in:
BT Templeton
parent
80687f2e4b
commit
b652e2b93f
5 changed files with 92 additions and 196 deletions
|
|
@ -139,7 +139,6 @@ ELISP_LANG_SOURCES = \
|
|||
language/elisp/runtime.scm \
|
||||
language/elisp/runtime/function-slot.scm \
|
||||
language/elisp/runtime/value-slot.scm \
|
||||
language/elisp/runtime/macros.scm \
|
||||
language/elisp/runtime/subrs.scm \
|
||||
language/elisp/spec.scm
|
||||
|
||||
|
|
|
|||
|
|
@ -22,11 +22,98 @@
|
|||
(defmacro @ (module symbol)
|
||||
`(guile-ref ,module ,symbol))
|
||||
|
||||
(defun funcall (function &rest arguments)
|
||||
(apply function arguments))
|
||||
(defmacro eval-and-compile (&rest body)
|
||||
`(progn
|
||||
(eval-when-compile ,@body)
|
||||
(progn ,@body)))
|
||||
|
||||
(defun fset (symbol definition)
|
||||
(funcall (@ (language elisp runtime subrs) fset) symbol definition))
|
||||
(eval-and-compile
|
||||
(defun funcall (function &rest arguments)
|
||||
(apply function arguments))
|
||||
(defun fset (symbol definition)
|
||||
(funcall (@ (language elisp runtime subrs) fset) symbol definition))
|
||||
(defun null (object)
|
||||
(if object nil t))
|
||||
(fset 'consp (@ (guile) pair?))
|
||||
(defun listp (object)
|
||||
(if object (consp object) t))
|
||||
(defun car (list)
|
||||
(if list (funcall (@ (guile) car) list) nil))
|
||||
(defun cdr (list)
|
||||
(if list (funcall (@ (guile) cdr) list) nil))
|
||||
(fset 'make-symbol (@ (guile) make-symbol))
|
||||
(defun signal (&rest args)
|
||||
(funcall (@ (guile) throw) 'elisp-error args)))
|
||||
|
||||
(defmacro lambda (&rest cdr)
|
||||
`#'(lambda ,@cdr))
|
||||
|
||||
(defmacro prog1 (first &rest body)
|
||||
(let ((temp (make-symbol "prog1-temp")))
|
||||
`(lexical-let ((,temp ,first))
|
||||
,@body
|
||||
,temp)))
|
||||
|
||||
(defmacro prog2 (form1 form2 &rest body)
|
||||
`(progn ,form1 (prog1 ,form2 ,@body)))
|
||||
|
||||
(defmacro cond (&rest clauses)
|
||||
(if (null clauses)
|
||||
nil
|
||||
(let ((first (car clauses))
|
||||
(rest (cdr clauses)))
|
||||
(if (listp first)
|
||||
(let ((condition (car first))
|
||||
(body (cdr first)))
|
||||
(if (null body)
|
||||
(let ((temp (make-symbol "cond-temp")))
|
||||
`(lexical-let ((,temp ,condition))
|
||||
(if ,temp
|
||||
,temp
|
||||
(cond ,@rest))))
|
||||
`(if ,condition
|
||||
(progn ,@body)
|
||||
(cond ,@rest))))
|
||||
(signal 'wrong-type-argument `(listp ,first))))))
|
||||
|
||||
(defmacro and (&rest conditions)
|
||||
(cond ((null conditions) t)
|
||||
((null (cdr conditions)) (car conditions))
|
||||
(t `(if ,(car conditions)
|
||||
(and ,@(cdr conditions))
|
||||
nil))))
|
||||
|
||||
(defmacro or (&rest conditions)
|
||||
(cond ((null conditions) nil)
|
||||
((null (cdr conditions)) (car conditions))
|
||||
(t (let ((temp (make-symbol "or-temp")))
|
||||
`(lexical-let ((,temp ,(car conditions)))
|
||||
(if ,temp
|
||||
,temp
|
||||
(or ,@(cdr conditions))))))))
|
||||
|
||||
(defmacro catch (tag &rest body)
|
||||
(let* ((temp (make-symbol "catch-temp"))
|
||||
(elisp-key (make-symbol "catch-elisp-key"))
|
||||
(dummy-key (make-symbol "catch-dummy-key"))
|
||||
(value (make-symbol "catch-value")))
|
||||
`(lexical-let ((,temp ,tag))
|
||||
(funcall (@ (guile) catch)
|
||||
t
|
||||
#'(lambda () ,@body)
|
||||
#'(lambda (,dummy-key ,elisp-key ,value)
|
||||
(if (eq ,elisp-key ,temp)
|
||||
,value
|
||||
(funcall (@ (guile) throw)
|
||||
,dummy-key
|
||||
,elisp-key
|
||||
,value)))))))
|
||||
|
||||
(defmacro unwind-protect (bodyform &rest unwindforms)
|
||||
`(funcall (@ (guile) dynamic-wind)
|
||||
#'(lambda () nil)
|
||||
#'(lambda () ,bodyform)
|
||||
#'(lambda () ,@unwindforms)))
|
||||
|
||||
(fset 'symbol-value (@ (language elisp runtime subrs) symbol-value))
|
||||
(fset 'symbol-function (@ (language elisp runtime subrs) symbol-function))
|
||||
|
|
@ -110,19 +197,11 @@
|
|||
|
||||
;;; List predicates
|
||||
|
||||
(fset 'consp (@ (guile) pair?))
|
||||
|
||||
(defun null (object)
|
||||
(if object nil t))
|
||||
|
||||
(fset 'not #'null)
|
||||
|
||||
(defun atom (object)
|
||||
(null (consp object)))
|
||||
|
||||
(defun listp (object)
|
||||
(or (consp object) (null object)))
|
||||
|
||||
(defun nlistp (object)
|
||||
(null (listp object)))
|
||||
|
||||
|
|
@ -134,16 +213,6 @@
|
|||
(fset 'append (@ (guile) append))
|
||||
(fset 'reverse (@ (guile) reverse))
|
||||
|
||||
(defun car (list)
|
||||
(if (null list)
|
||||
nil
|
||||
(funcall (@ (guile) car) list)))
|
||||
|
||||
(defun cdr (list)
|
||||
(if (null list)
|
||||
nil
|
||||
(funcall (@ (guile) cdr) list)))
|
||||
|
||||
(defun car-safe (object)
|
||||
(if (consp object)
|
||||
(car object)
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@
|
|||
set-variable!
|
||||
runtime-error
|
||||
macro-error)
|
||||
#:export-syntax (built-in-macro defspecial prim))
|
||||
#:export-syntax (defspecial prim))
|
||||
|
||||
;;; This module provides runtime support for the Elisp front-end.
|
||||
|
||||
|
|
@ -118,15 +118,6 @@
|
|||
datum))
|
||||
data)))))
|
||||
|
||||
(define-syntax built-in-macro
|
||||
(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 ()
|
||||
|
|
|
|||
|
|
@ -19,16 +19,6 @@
|
|||
(define-module (language elisp runtime function-slot)
|
||||
#:use-module ((language elisp runtime subrs)
|
||||
#:select (apply))
|
||||
#:use-module ((language elisp runtime macros)
|
||||
#:select
|
||||
((macro-lambda . lambda)
|
||||
(macro-prog1 . prog1)
|
||||
(macro-prog2 . prog2)
|
||||
(macro-cond . cond)
|
||||
(macro-and . and)
|
||||
(macro-or . or)
|
||||
(macro-catch . catch)
|
||||
(macro-unwind-protect . unwind-protect)))
|
||||
#:use-module ((language elisp compile-tree-il)
|
||||
#:select
|
||||
((compile-progn . progn)
|
||||
|
|
@ -75,14 +65,5 @@
|
|||
defmacro
|
||||
#{`}#
|
||||
quote)
|
||||
;; macros
|
||||
#:re-export (lambda
|
||||
prog1
|
||||
prog2
|
||||
cond
|
||||
and
|
||||
or
|
||||
catch
|
||||
unwind-protect)
|
||||
;; functions
|
||||
#:re-export (apply))
|
||||
|
|
|
|||
|
|
@ -1,144 +0,0 @@
|
|||
;;; Guile Emacs Lisp
|
||||
|
||||
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
|
||||
;;;
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Lesser General Public
|
||||
;;; License as published by the Free Software Foundation; either
|
||||
;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; This library is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; Lesser General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;; License along with this library; if not, write to the Free Software
|
||||
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (language elisp runtime macros)
|
||||
#:use-module (language elisp runtime))
|
||||
|
||||
;;; This module contains the macro definitions of elisp symbols. In
|
||||
;;; contrast to the other runtime modules, those are used directly
|
||||
;;; 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.
|
||||
|
||||
(built-in-macro prog1
|
||||
(lambda (form1 . rest)
|
||||
(let ((temp (gensym)))
|
||||
`(lexical-let ((,temp ,form1))
|
||||
,@rest
|
||||
,temp))))
|
||||
|
||||
(built-in-macro prog2
|
||||
(lambda (form1 form2 . rest)
|
||||
`(progn ,form1 (prog1 ,form2 ,@rest))))
|
||||
|
||||
;;; Impement the cond form as nested if's. A special case is a
|
||||
;;; (condition) subform, in which case we need to return the condition
|
||||
;;; itself if it is true and thus save it in a local variable before
|
||||
;;; testing it.
|
||||
|
||||
(built-in-macro cond
|
||||
(lambda (. clauses)
|
||||
(let iterate ((tail clauses))
|
||||
(if (null? tail)
|
||||
'nil
|
||||
(let ((cur (car tail))
|
||||
(rest (iterate (cdr tail))))
|
||||
(prim cond
|
||||
((prim or (not (list? cur)) (null? cur))
|
||||
(macro-error "invalid clause in cond" cur))
|
||||
((null? (cdr cur))
|
||||
(let ((var (gensym)))
|
||||
`(lexical-let ((,var ,(car cur)))
|
||||
(if ,var
|
||||
,var
|
||||
,rest))))
|
||||
(else
|
||||
`(if ,(car cur)
|
||||
(progn ,@(cdr cur))
|
||||
,rest))))))))
|
||||
|
||||
;;; The and and or forms can also be easily defined with macros.
|
||||
|
||||
(built-in-macro and
|
||||
(case-lambda
|
||||
(() 't)
|
||||
((x) x)
|
||||
((x . args)
|
||||
(let iterate ((x x) (tail args))
|
||||
(if (null? tail)
|
||||
x
|
||||
`(if ,x
|
||||
,(iterate (car tail) (cdr tail))
|
||||
nil))))))
|
||||
|
||||
(built-in-macro or
|
||||
(case-lambda
|
||||
(() 'nil)
|
||||
((x) x)
|
||||
((x . args)
|
||||
(let iterate ((x x) (tail args))
|
||||
(if (null? tail)
|
||||
x
|
||||
(let ((var (gensym)))
|
||||
`(lexical-let ((,var ,x))
|
||||
(if ,var
|
||||
,var
|
||||
,(iterate (car tail) (cdr tail))))))))))
|
||||
|
||||
;;; Exception handling. unwind-protect and catch are implemented as
|
||||
;;; macros (throw is a built-in function).
|
||||
|
||||
;;; catch and throw can mainly be implemented directly using Guile's
|
||||
;;; primitives for exceptions, the only difficulty is that the keys used
|
||||
;;; within Guile must be symbols, while elisp allows any value and
|
||||
;;; checks for matches using eq (eq?). We handle this by using always #t
|
||||
;;; as key for the Guile primitives and check for matches inside the
|
||||
;;; handler; if the elisp keys are not eq?, we rethrow the exception.
|
||||
|
||||
(built-in-macro catch
|
||||
(lambda (tag . body)
|
||||
(if (null? body)
|
||||
(macro-error "catch with empty body"))
|
||||
(let ((tagsym (gensym)))
|
||||
`(lexical-let ((,tagsym ,tag))
|
||||
((guile-primitive catch)
|
||||
#t
|
||||
(lambda () ,@body)
|
||||
,(let* ((dummy-key (gensym))
|
||||
(elisp-key (gensym))
|
||||
(value (gensym))
|
||||
(arglist `(,dummy-key ,elisp-key ,value)))
|
||||
`(with-always-lexical
|
||||
,arglist
|
||||
(lambda ,arglist
|
||||
(if (eq ,elisp-key ,tagsym)
|
||||
,value
|
||||
((guile-primitive throw) ,dummy-key ,elisp-key
|
||||
,value))))))))))
|
||||
|
||||
;;; unwind-protect is just some weaker construct as dynamic-wind, so
|
||||
;;; straight-forward to implement.
|
||||
|
||||
(built-in-macro unwind-protect
|
||||
(lambda (body . clean-ups)
|
||||
(if (null? clean-ups)
|
||||
(macro-error "unwind-protect without cleanup code"))
|
||||
`((guile-primitive dynamic-wind)
|
||||
(lambda () nil)
|
||||
(lambda () ,body)
|
||||
(lambda () ,@clean-ups))))
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue