~ chicken-core (chicken-5) 1f74df5e6dc969459cacc15f890e24e88c303199
commit 1f74df5e6dc969459cacc15f890e24e88c303199
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Mar 21 15:27:06 2011 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Mar 21 15:27:06 2011 +0100
started writing functor tests, some syntax fixes
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 8b1034fe..4e805295 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1136,12 +1136,12 @@
'functor '()
(##sys#er-transformer
(lambda (x r c)
- (##sys#check-syntax 'functor x '(_ (symbol . #((symbol _) 0)) . _))
+ (##sys#check-syntax 'functor x '(_ (symbol . #((symbol _) 0)) _ . _))
(let* ((x (##sys#strip-syntax x))
(head (cadr x))
(name (car head))
- (body (cddr x))
- (%quote (r 'quote))
+ (exps (caddr x))
+ (body (cdddr x))
(registration
`(##sys#register-functor
',name
@@ -1150,6 +1150,7 @@
(exps (##sys#validate-exports (cadr arg) 'functor)))
(cons argname exps)))
(cdr head))
+ ',(##sys#validate-exports exps 'functor)
',body)))
`(##core#module
,name
diff --git a/expand.scm b/expand.scm
index 4e45422f..be97e5d2 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1314,22 +1314,19 @@
(lambda (x r c)
(let ((len (length x)))
(cond ((and (fx>= len 4) (c (r '=) (caddr x)))
- (##sys#check-syntax 'module x '(_ symbol _ (symbol . #(_ 1)) . #(_ 0 1)))
(let* ((x (##sys#strip-syntax x))
(name (cadr x))
(app (cadddr x)))
- (##sys#instantiate-functor
- name
- (car app) ; functor name
- (cdr app) ; functor arguments
- (if (null? (cddddr x))
- '*
- (##sys#validate-exports (car (cddddr x)) name)))))
- ((and (fx= len 3) (symbol? (cadr x)))
- (##sys#check-syntax 'module x '(_ symbol symbol))
- (let ((x (##sys#strip-syntax x)))
- (##sys#register-module-alias (cadr x) (caddr x))
- '(##core#undefined)))
+ (cond ((symbol? app)
+ (##sys#register-module-alias name app)
+ '(##core#undefined))
+ (else
+ (##sys#check-syntax
+ 'module x '(_ symbol _ (symbol . #(_ 1)) . #(_ 0 1)))
+ (##sys#instantiate-functor
+ name
+ (car app) ; functor name
+ (cdr app)))))); functor arguments
(else
(##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
;;XXX use module name in "loc" argument?
diff --git a/manual/Modules b/manual/Modules
index e0b3f0c7..9be38bc3 100644
--- a/manual/Modules
+++ b/manual/Modules
@@ -341,16 +341,53 @@ must be available separately.
=== Functors
-A ''functor'' is a higher-order module that expands can be
-parameterized with other modules. A functor defines the body of a
-module for a set or argument modules and can be instantiated with
-concrete module names specializing the code contained in the
-functor. This is best explained with an example:
+A ''functor'' is a higher-order module that can be parameterized with
+other modules. A functor defines the body of a module for a set or
+argument modules and can be instantiated with concrete module names
+specializing the code contained in the functor. This is best explained
+with an example:
<enscript highlight=scheme>
XXX need example here...
</enscript>
+The general syntax of a functor definition looks like this:
+
+<enscript highlight=scheme>
+(functor (FUNCTORNAME (ARGUMENTMODULE1 EXPORTS1) ...)
+ FUNCTOREXPORTS
+ BODY)
+</enscript>
+
+This functor definition does not generate any code. This is done
+by ''instantiating'' the functor for specific input modules:
+
+<enscript highlight=scheme>
+(module MODULENAME = (FUNCTORNAME MODULENAME1 ...))
+</enscript>
+
+Inside {{BODY}}, references to {{ARGUMENTMODULE}} will be replaced by
+the corresponding {{MODUELNAME}} argument. The instantiation expands
+into the complete functor-code {{BODY}} and as such can be considered
+a particular sort of macro-expansion. Note that there is no
+requirement that a specific export of an argument-module must be
+syntax or non-syntax - it can be syntax in one instantiation and a
+function definition in another.
+
+A "degenerate" form of module assignment is
+
+<enscript highlight=scheme>
+(module MODULENAME1 = MODULENAME2)
+</enscript>
+
+which just defines the alias {{MODULENAME1}} for the module {{MODULENAME2}}.
+
+Since functors exist at compile time, they can be stored in
+import-libraries via {{-emit-import-library FUNCTORNAME}} or
+{{-emit-all-import-libraries}} (see [[Using the compiler]] for more
+information about this). That allows you to import functors for later
+instantiation.
+
---
Previous: [[Macros]]
diff --git a/modules.scm b/modules.scm
index 2203ab20..8aea82de 100644
--- a/modules.scm
+++ b/modules.scm
@@ -726,16 +726,17 @@
(err "invalid interface specification" x exps)))
(else (err "invalid export" x exps))))))))))
-(define (##sys#register-functor name fargs body)
- (putp name '##core#functor (cons fargs body)))
+(define (##sys#register-functor name fargs fexps body)
+ (putp name '##core#functor (cons fargs (cons fexps body))))
-(define (##sys#instantiate-functor name fname args exports)
+(define (##sys#instantiate-functor name fname args)
(let ((funcdef (getp fname '##core#functor)))
(define (err . args)
(apply ##sys#syntax-error-hook name args))
(unless funcdef (err "instantation of undefined functor" fname))
(let ((fargs (car funcdef))
- (body (cdr funcdef)))
+ (exports (cadr funcdef))
+ (body (cddr funcdef)))
(define (merr)
(err "argument list mismatch in functor instantiation"
(cons name args) (cons fname (map car fargs))))
diff --git a/tests/QUEUE.scm b/tests/QUEUE.scm
new file mode 100644
index 00000000..b9f79868
--- /dev/null
+++ b/tests/QUEUE.scm
@@ -0,0 +1,9 @@
+;;;; QUEUE.scm
+
+
+(define-interface QUEUE
+ empty-queue
+ enqueue
+ head
+ empty?
+ dequeue)
diff --git a/tests/breadth-first.scm b/tests/breadth-first.scm
new file mode 100644
index 00000000..0b8bac2f
--- /dev/null
+++ b/tests/breadth-first.scm
@@ -0,0 +1,20 @@
+;;;; breadth-first.scm
+
+
+(include "QUEUE")
+
+
+(functor (breadth-first (Q QUEUE)) (search)
+ (import scheme chicken Q)
+ (use srfi-1)
+
+ (define (enqlist q xs)
+ (fold (lambda (x q) (enqueue q x)) q xs))
+
+ (define (search next x)
+ (define (bfs q)
+ (if (empty? q)
+ '()
+ (let ((y (head q)))
+ (cons y (lambda () (bfs (enqlist (dequeue q) (next y))))))))
+ (bfs (enqueue empty-queue x))) )
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
new file mode 100644
index 00000000..6cbadd2c
--- /dev/null
+++ b/tests/functor-tests.scm
@@ -0,0 +1,45 @@
+;;;; functor-tests.scm
+
+
+(include "test-queue")
+(include "breadth-first")
+
+
+(module queue1 ((interface: QUEUE))
+ (import scheme)
+ (define empty-queue '())
+ (define (enqueue q x) (append q (list x)))
+ (define empty? null?)
+ (define head car)
+ (define dequeue cdr) )
+
+
+(module queue2 ((interface: QUEUE))
+ (import scheme chicken)
+ (define-record entry q x)
+ (define empty-queue #f)
+ (define enqueue make-entry)
+ (define empty? not)
+ (define (head q)
+ (let ((q2 (entry-q q)))
+ (if (empty? q2) (entry-x q) (head q2))))
+ (define (dequeue q)
+ (let ((q2 (entry-q q)))
+ (if (empty? q2) empty-queue (make-queue (dequeue q) x)))) )
+
+
+(module queue3 ((interface: QUEUE))
+ (import scheme chicken)
+ (define-record queue heads tails)
+ (define empty-queue (make-queue '() '()))
+ (define (norm q)
+ (if (null? (queue-heads q))
+ (make-queue (reverse (queue-tails q)) '())
+ q))
+ (define (enqueue q x)
+ (norm (make-queue (queue-heads q) (cons x (queue-tails q)))))
+ (define (empty? q)
+ (and (null? (queue-heads q)) (null? (queue-tails q))))
+ (define (head q) (car (queue-heads q)))
+ (define (dequeue q)
+ (norm (make-queue (cdr (queue-heads q)) (queue-tails q)))) )
diff --git a/tests/simple-functors-test.scm b/tests/simple-functors-test.scm
new file mode 100644
index 00000000..c1dee7c9
--- /dev/null
+++ b/tests/simple-functors-test.scm
@@ -0,0 +1,22 @@
+;;;; simple-functors-test.scm
+
+
+(define-interface stuff (a b))
+
+(module foo ((interface: stuff))
+(import scheme)
+(define a 1)
+(define b 2))
+
+(module f = foo)
+
+(functor
+ (do-things (arg ((interface: stuff)))) (do-it)
+ (import scheme arg)
+ (define (do-it) (list a b)))
+
+(module bar = (do-things f))
+
+(import bar)
+(assert (equal? '(1 2) (doit)))
+
diff --git a/tests/test-queue.scm b/tests/test-queue.scm
new file mode 100644
index 00000000..aaed0972
--- /dev/null
+++ b/tests/test-queue.scm
@@ -0,0 +1,17 @@
+;;;; test-queue.scm
+
+
+(include "QUEUE")
+
+
+(functor (test-queue (Q QUEUE)) *
+ (import scheme chicken Q)
+ (use srfi-1)
+
+ (define (list->queue lst)
+ (fold (lambda (x q) (enqueue q x)) empty-queue l))
+
+ (define (queue->list q)
+ (if (empty? q)
+ '()
+ (cons (head q) (queue->list (dequeue q))))) )
Trap