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

* Further Elisp translator work.

Browse source
This commit is contained in:
Neil Jerram 2002-02-04 21:13:46 +00:00
parent 7c5c279671
commit 877accb11a
6 changed files with 140 additions and 110 deletions
Download patch file Download diff file Expand all files Collapse all files

21
lang/elisp/ChangeLog
View file

@ -1,3 +1,24 @@
2002-02-04 Neil Jerram <neil@ossau.uklinux.net>
* primitives/syntax.scm (parse-formals, transform-lambda,
interactive-spec, set-not-subr!, transform-lambda/interactive):
Move into internals/lambda.scm so that these can also be used
by...
* internals/fset.scm (elisp-apply): Use `eval' and
`transform-lambda/interactive' to turn a quoted lambda expression
into a Scheme procedure.
* transform.scm (m-quasiquote): Don't quote `quasiquote' in
transformed code.
(transformer): Transform '() to #nil.
2002-02-03 Neil Jerram <neil@ossau.uklinux.net>
* internals/Makefile.am (elisp_sources): Add lambda.scm.
* internals/lambda.scm (lang): New file.
2002-02-01 Neil Jerram <neil@ossau.uklinux.net>
* transform.scm (transformer), primitives/syntax.scm (let*):

1
lang/elisp/internals/Makefile.am
View file

@ -27,6 +27,7 @@ elisp_sources = \
evaluation.scm \
format.scm \
fset.scm \
lambda.scm \
load.scm \
null.scm \
set.scm \

6
lang/elisp/internals/fset.scm
View file

@ -1,6 +1,7 @@
(define-module (lang elisp internals fset)
#:use-module (lang elisp internals signal)
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals lambda)
#:use-module (lang elisp internals signal)
#:export (fset
fref
fref/error-if-void
@ -105,7 +106,8 @@
function)
((and (pair? function)
(eq? (car function) 'lambda))
(eval function the-elisp-module))
(eval (transform-lambda/interactive function '<elisp-lambda>)
the-root-module))
(else
(signal 'invalid-function (list function))))
args))

108
lang/elisp/internals/lambda.scm Normal file
View file

@ -0,0 +1,108 @@
(define-module (lang elisp internals lambda)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp transform)
#:export (parse-formals
transform-lambda/interactive
interactive-spec))
;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
;;; returns three values: (i) list of symbols for required arguments,
;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
;;; #f if there is no rest argument.
(define (parse-formals formals)
(letrec ((do-required
(lambda (required formals)
(if (null? formals)
(values (reverse required) '() #f)
(let ((next-sym (car formals)))
(cond ((not (symbol? next-sym))
(error "Bad formals (non-symbol in required list)"))
((eq? next-sym '&optional)
(do-optional required '() (cdr formals)))
((eq? next-sym '&rest)
(do-rest required '() (cdr formals)))
(else
(do-required (cons next-sym required)
(cdr formals))))))))
(do-optional
(lambda (required optional formals)
(if (null? formals)
(values (reverse required) (reverse optional) #f)
(let ((next-sym (car formals)))
(cond ((not (symbol? next-sym))
(error "Bad formals (non-symbol in optional list)"))
((eq? next-sym '&rest)
(do-rest required optional (cdr formals)))
(else
(do-optional required
(cons next-sym optional)
(cdr formals))))))))
(do-rest
(lambda (required optional formals)
(if (= (length formals) 1)
(let ((next-sym (car formals)))
(if (symbol? next-sym)
(values (reverse required) (reverse optional) next-sym)
(error "Bad formals (non-symbol rest formal)")))
(error "Bad formals (more than one rest formal)")))))
(do-required '() (cond ((list? formals)
formals)
((symbol? formals)
(list '&rest formals))
(else
(error "Bad formals (not a list or a single symbol)"))))))
(define (transform-lambda exp)
(call-with-values (lambda () (parse-formals (cadr exp)))
(lambda (required optional rest)
(let ((num-required (length required))
(num-optional (length optional)))
`(,lambda %--args
(,let ((%--num-args (,length %--args)))
(,cond ((,< %--num-args ,num-required)
(,error "Wrong number of args (not enough required args)"))
,@(if rest
'()
`(((,> %--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)))))))))))
(define (set-not-subr! proc boolean)
(set! (not-subr? proc) boolean))
(define (transform-lambda/interactive exp name)
(fluid-set! interactive-spec #f)
(let* ((x (transform-lambda exp))
(is (fluid-ref interactive-spec)))
`(,let ((%--lambda ,x))
(,set-procedure-property! %--lambda (,quote name) (,quote ,name))
(,set-not-subr! %--lambda #t)
,@(if is
`((,set! (,interactive-spec %--lambda) (,quote ,is)))
'())
%--lambda)))
(define interactive-spec (make-fluid))

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

@ -1,13 +1,13 @@
(define-module (lang elisp primitives syntax)
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals lambda)
#:use-module (lang elisp internals trace)
#:use-module (lang elisp transform))
;;; Define Emacs Lisp special forms as macros. This is much more
;;; flexible than handling them specially in the translator: allows
;;; them to be redefined, and hopefully allows better source location
;;; tracking.
;;; Define Emacs Lisp special forms as macros. This is more flexible
;;; than handling them specially in the translator: allows them to be
;;; redefined, and hopefully allows better source location tracking.
;;; {Variables}
@ -44,108 +44,6 @@
;;; {lambda, function and macro definitions}
;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
;;; returns three values: (i) list of symbols for required arguments,
;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
;;; #f if there is no rest argument.
(define (parse-formals formals)
(letrec ((do-required
(lambda (required formals)
(if (null? formals)
(values (reverse required) '() #f)
(let ((next-sym (car formals)))
(cond ((not (symbol? next-sym))
(error "Bad formals (non-symbol in required list)"))
((eq? next-sym '&optional)
(do-optional required '() (cdr formals)))
((eq? next-sym '&rest)
(do-rest required '() (cdr formals)))
(else
(do-required (cons next-sym required)
(cdr formals))))))))
(do-optional
(lambda (required optional formals)
(if (null? formals)
(values (reverse required) (reverse optional) #f)
(let ((next-sym (car formals)))
(cond ((not (symbol? next-sym))
(error "Bad formals (non-symbol in optional list)"))
((eq? next-sym '&rest)
(do-rest required optional (cdr formals)))
(else
(do-optional required
(cons next-sym optional)
(cdr formals))))))))
(do-rest
(lambda (required optional formals)
(if (= (length formals) 1)
(let ((next-sym (car formals)))
(if (symbol? next-sym)
(values (reverse required) (reverse optional) next-sym)
(error "Bad formals (non-symbol rest formal)")))
(error "Bad formals (more than one rest formal)")))))
(do-required '() (cond ((list? formals)
formals)
((symbol? formals)
(list '&rest formals))
(else
(error "Bad formals (not a list or a single symbol)"))))))
(define (transform-lambda exp)
(call-with-values (lambda () (parse-formals (cadr exp)))
(lambda (required optional rest)
(let ((num-required (length required))
(num-optional (length optional)))
`(,lambda %--args
(,let ((%--num-args (,length %--args)))
(,cond ((,< %--num-args ,num-required)
(,error "Wrong number of args (not enough required args)"))
,@(if rest
'()
`(((,> %--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)))))))))))
(define interactive-spec (make-fluid))
(define (set-not-subr! proc boolean)
(set! (not-subr? proc) boolean))
(define (transform-lambda/interactive exp name)
(fluid-set! interactive-spec #f)
(let* ((x (transform-lambda exp))
(is (fluid-ref interactive-spec)))
`(,let ((%--lambda ,x))
(,set-procedure-property! %--lambda (,quote name) (,quote ,name))
(,set-not-subr! %--lambda #t)
,@(if is
`((,set! (,interactive-spec %--lambda) (,quote ,is)))
'())
%--lambda)))
(fset 'lambda
(procedure->memoizing-macro
(lambda (exp env)

4
lang/elisp/transform.scm
View file

@ -16,7 +16,7 @@
(define (transformer x)
(cond ((eq? x 'nil) %nil)
((eq? x 't) #t)
((null? x) '())
((null? x) %nil)
((not (pair? x)) x)
((and (pair? (car x))
(eq? (caar x) 'quasiquote))
@ -51,7 +51,7 @@
(else (syntax-error x))))
(define (m-quasiquote exp env)
(cons 'quasiquote
(cons quasiquote
(map transform-inside-qq (cdr exp))))
(define (transform-inside-qq x)