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

Implemented the flet and flet* extensions.

Browse source 
* module/language/elisp/README: Document it.
* module/language/elisp/compile-tree-il.scm: Implement flet and flet*.
* test-suite/tests/elisp-compiler.test: Test flet and flet*.
This commit is contained in:
Daniel Kraft 2009-07-24 09:56:13 +02:00
parent 3709984696
commit e8f18b3f63
3 changed files with 77 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/language/elisp/README
View file

@ -32,7 +32,9 @@ Especially still missing:
Other ideas and things to think about:
* %nil vs. #f/'() handling in Guile
* flet, lexical-let and/or optional lexical binding as extensions
* lexical-let and/or optional lexical binding as extensions
* compiler options for all lexical binding, no void checks
Extensions over original elisp:
* (guile-ref module symbol) construct to build a (@ module symbol) from elisp
* flet and flet*

93
module/language/elisp/compile-tree-il.scm
View file

@ -346,6 +346,7 @@
(error "non-pair expression contains unquotes" expr))
(make-const loc expr)))
; Compile a dolist construct.
; This is compiled to something along:
; (with-fluid* iter-var %nil
@ -385,6 +386,45 @@
(list (compile-expr bind iter-list))))))))
; Compile let and let* expressions. The code here is used both for let/let*
; and flet/flet*, just with a different bindings module.
; Let is done with a single call to with-fluids* binding them locally to new
; values all "at once".
(define (generate-let loc bind module bindings body)
(let ((let-bind (process-let-bindings loc bindings)))
(begin
(for-each (lambda (sym)
(mark-fluid-needed! bind sym module))
(map car let-bind))
(call-primitive loc 'with-fluids*
(make-application loc (make-primitive-ref loc 'list)
(map (lambda (el)
(make-module-ref loc module (car el) #t))
let-bind))
(make-application loc (make-primitive-ref loc 'list)
(map (lambda (el)
(compile-expr bind (cdr el)))
let-bind))
(make-lambda loc '() '() '()
(make-sequence loc (map (compiler bind) body)))))))
; Let* is compiled to a cascaded set of with-fluid* for each binding in turn
; so that each one already sees the preceding bindings.
(define (generate-let* loc bind module bindings body)
(let ((let-bind (process-let-bindings loc bindings)))
(begin
(for-each (lambda (sym)
(mark-fluid-needed! bind sym module))
(map car let-bind))
(let iterate ((tail let-bind))
(if (null? tail)
(make-sequence loc (map (compiler bind) body))
(call-primitive loc 'with-fluid*
(make-module-ref loc module (caar tail) #t)
(compile-expr bind (cdar tail))
(make-lambda loc '() '() '() (iterate (cdr tail)))))))))
; Compile a symbol expression. This is a variable reference or maybe some
; special value like nil.
@ -516,47 +556,26 @@
(cons (set-variable! loc bind sym value-slot val)
(iterate (cdr tailtail)))))))))))
; Let is done with a single call to with-fluids* binding them locally to new
; values all "at once".
; let/let* and flet/flet* are done using the generate-let/generate-let*
; methods.
((let ,bindings . ,body) (guard (and (list? bindings)
(list? body)
(not (null? bindings))
(not (null? body))))
(let ((let-bind (process-let-bindings loc bindings)))
(begin
(for-each (lambda (sym)
(mark-fluid-needed! bind sym value-slot))
(map car let-bind))
(call-primitive loc 'with-fluids*
(make-application loc (make-primitive-ref loc 'list)
(map (lambda (el)
(make-module-ref loc value-slot (car el) #t))
let-bind))
(make-application loc (make-primitive-ref loc 'list)
(map (lambda (el)
(compile-expr bind (cdr el)))
let-bind))
(make-lambda loc '() '() '()
(make-sequence loc (map (compiler bind) body)))))))
; Let* is compiled to a cascaded set of with-fluid* for each binding in turn
; so that each one already sees the preceding bindings.
((let* ,bindings . ,body) (guard (and (list? bindings)
(list? body)
(generate-let loc bind value-slot bindings body))
((flet ,bindings . ,body) (guard (and (list? bindings)
(not (null? bindings))
(not (null? body))))
(let ((let-bind (process-let-bindings loc bindings)))
(begin
(for-each (lambda (sym)
(mark-fluid-needed! bind sym value-slot))
(map car let-bind))
(let iterate ((tail let-bind))
(if (null? tail)
(make-sequence loc (map (compiler bind) body))
(call-primitive loc 'with-fluid*
(make-module-ref loc value-slot (caar tail) #t)
(compile-expr bind (cdar tail))
(make-lambda loc '() '() '() (iterate (cdr tail)))))))))
(generate-let loc bind function-slot bindings body))
((let* ,bindings . ,body) (guard (and (list? bindings)
(not (null? bindings))
(not (null? body))))
(generate-let* loc bind value-slot bindings body))
((flet* ,bindings . ,body) (guard (and (list? bindings)
(not (null? bindings))
(not (null? body))))
(generate-let* loc bind function-slot bindings body))
; guile-ref allows building TreeIL's module references from within
; elisp as a way to access data (and primitives, for instance) within
@ -712,6 +731,8 @@
; expression we need to make sure all fluids for symbols used during the
; compilation are created using the generate-ensure-fluid function.
; XXX: Maybe don't pass bind around but instead use a fluid for it?
(define (compile-tree-il expr env opts)
(values
(let* ((bind (make-bindings))

18
test-suite/tests/elisp-compiler.test
View file

@ -291,7 +291,23 @@
(fset 'b 5)
(and (fboundp 'b) (fboundp 'test)
(not (fboundp 'a))
(= a 1)))))
(= a 1))))
(pass-if "flet and flet*"
(progn (defun foobar () 42)
(defun test () (foobar))
(and (= (test) 42)
(flet ((foobar (lambda () 0))
(myfoo (symbol-function 'foobar)))
(and (= (myfoo) 42)
(= (test) 0)))
(flet* ((foobar (lambda () 0))
(myfoo (symbol-function 'foobar)))
(= (myfoo) 0))
(flet (foobar)
(defun foobar () 0)
(= (test) 0))
(= (test) 42)))))
(with-test-prefix/compile "Calling Functions"