From e8f18b3f634ce49f3b05e30789ce9d3c668aa571 Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Fri, 24 Jul 2009 09:56:13 +0200 Subject: [PATCH] Implemented the flet and flet* extensions. * 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*. --- module/language/elisp/README | 4 +- module/language/elisp/compile-tree-il.scm | 93 ++++++++++++++--------- test-suite/tests/elisp-compiler.test | 18 ++++- 3 files changed, 77 insertions(+), 38 deletions(-) diff --git a/module/language/elisp/README b/module/language/elisp/README index 140124dba..dbb34a76c 100644 --- a/module/language/elisp/README +++ b/module/language/elisp/README @@ -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* diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index e44303b4c..2cfe4c28c 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -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)) diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test index 67dbc70ed..b76d4fad7 100644 --- a/test-suite/tests/elisp-compiler.test +++ b/test-suite/tests/elisp-compiler.test @@ -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"