~ chicken-core (chicken-5) 0b1b7f7f58cfc750e9330dab63d604a1ae554053
commit 0b1b7f7f58cfc750e9330dab63d604a1ae554053
Author: felix <felix@z.(none)>
AuthorDate: Mon Mar 21 21:25:22 2011 +0100
Commit: felix <felix@z.(none)>
CommitDate: Mon Mar 21 21:25:22 2011 +0100
allow single interface name as export-list, catch (define-interface * ...), more tests, added to runtests, not tried out yet
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 4e805295..04e6658c 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1119,15 +1119,20 @@
(##sys#check-syntax 'define-interface x '(_ symbol _))
(let ((name (##sys#strip-syntax (cadr x)))
(%quote (r 'quote)))
+ (when (eq? '* name)
+ (##sys#syntax-error-hook
+ 'define-interface "`*' is not allowed as a name for an interface"))
`(,(r 'begin-for-syntax)
(##sys#register-interface
(,%quote ,name)
(,%quote ,(let ((exps (##sys#strip-syntax (caddr x))))
(cond ((eq? '* exps) '*)
((symbol? exps) `(#:interface ,exps))
- ((list? exps) (##sys#validate-exports exps 'define-interface))
- (else (##sys#syntax-error-hook
- 'define-interface "invalid exports" (caddr x))))))))))))
+ ((list? exps)
+ (##sys#validate-exports exps 'define-interface))
+ (else
+ (##sys#syntax-error-hook
+ 'define-interface "invalid exports" (caddr x))))))))))))
;;; functor definition
diff --git a/distribution/manifest b/distribution/manifest
index 6f805100..72f988e0 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -173,6 +173,13 @@ tests/dwindtst.scm
tests/dwindtst.expected
tests/callback-tests.scm
tests/reader-tests.scm
+tests/simple-functors-test.scm
+tests/breadth-first.scm
+tests/QUEUE.scm
+tests/test-queue.scm
+tests/functor-tests.scm
+tests/square-functor.scm
+tests/use-square-functor.scm
tweaks.scm
utils.scm
apply-hack.x86.S
diff --git a/expand.scm b/expand.scm
index be97e5d2..ffc746b9 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1322,15 +1322,17 @@
'(##core#undefined))
(else
(##sys#check-syntax
- 'module x '(_ symbol _ (symbol . #(_ 1)) . #(_ 0 1)))
+ 'module x '(_ symbol _ (symbol . #(_ 1))))
(##sys#instantiate-functor
name
- (car app) ; functor name
- (cdr app)))))); functor arguments
+ (car app) ; functor name
+ (cdr app)))))) ; functor arguments
(else
(##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
;;XXX use module name in "loc" argument?
- (let ((exports (##sys#validate-exports (##sys#strip-syntax (caddr x)) 'module)))
+ (let ((exports
+ (##sys#validate-exports
+ (##sys#strip-syntax (caddr x)) 'module)))
`(##core#module
,(cadr x)
,(if (eq? '* exports)
diff --git a/manual/Modules b/manual/Modules
index 9be38bc3..4e67b944 100644
--- a/manual/Modules
+++ b/manual/Modules
@@ -36,6 +36,7 @@ CHICKEN's module system has the following features and shortcomings:
* Supports batch-compilation of separate compilation units
* No separate "identifier" type is used, all identifiers appearing in code and processed in expansions are symbols
* The module system is fully optional
+* Parameterized modules are supported
==== module
@@ -43,6 +44,8 @@ CHICKEN's module system has the following features and shortcomings:
<macro>(module NAME (EXPORT ...) BODY ...)</macro><br>
<macro>(module NAME (EXPORT ...) FILENAME)</macro>
<macro>(module NAME * BODY ...)</macro>
+<macro>(module NAME1 = NAME2)</macro>
+<macro>(module NAME = (FUNCTORNAME MODULENAME1 ...))</macro>
Defines a module with the name {{NAME}}, a set of exported bindings
and a contained sequence of toplevel expressions that are evaluated in
@@ -67,14 +70,23 @@ opportunities for optimization).
interface to be added to the list of exported identifiers of this
module.
-As a special case, specifying {{*}} instead of an export-list
-will export all definitions.
+As a special case, specifying {{*}} instead of an export-list will
+export all definitions. As another special case, the export-list may
+be a symbol naming an interface.
When the {{BODY}} consists of a single string, it is treated
like {{(include FILENAME)}}.
+The syntax {{(module NAME1 = NAME2)}} defines an alias {{NAME1}}
+for the module {{NAME2}}, so {{NAME1}} can be used in place of
+{{NAME2}} in all forms that accept module names.
+
+{{(module NAME = (FUNCTORNAME MODULENAME1 ...))}} instantiates
+a ''functor'' (see below for information about functors).
+
Nested modules, modules not at toplevel (i.e. local modules) or
-mutually recursive modules are not supported.
+mutually recursive modules are not supported. As an exception
+module alias definitions are allowed inside a module definition.
When compiled, the module information, including exported macros
is stored in the generated binary and available when loading
@@ -374,14 +386,6 @@ 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
diff --git a/modules.scm b/modules.scm
index 8aea82de..c0a90fdb 100644
--- a/modules.scm
+++ b/modules.scm
@@ -701,7 +701,11 @@
;; expects "exps" to be stripped
(define (err . args)
(apply ##sys#syntax-error-hook loc args))
+ (define (iface name)
+ (or (getp name '##core#interface)
+ (err "unknown interface" x exps)))
(cond ((eq? '* exps) exps)
+ ((symbol? exps) (iface exps))
((not (list? exps))
(err "invalid exports" exps))
(else
@@ -718,11 +722,7 @@
(cons (cdr x) (loop (cdr xps)))) ; currently not used
((eq? #:interface (car x))
(if (and (pair? (cdr x)) (symbol? (cadr x)))
- (cond ((getp (cadr x) '##core#interface) =>
- (lambda (iface)
- (append iface (loop (cdr xps)))))
- (else
- (err "unknown interface" x exps)))
+ (iface (cadr x))
(err "invalid interface specification" x exps)))
(else (err "invalid export" x exps))))))))))
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index af279ea9..0cbfde2b 100644
--- a/tests/functor-tests.scm
+++ b/tests/functor-tests.scm
@@ -1,25 +1,33 @@
;;;; functor-tests.scm
+(use srfi-1 data-structures)
+
+
(include "test-queue")
(include "breadth-first")
-(module queue1 ((interface: QUEUE))
- (import scheme)
+(module queue1 QUEUE
+ (import (rename scheme
+ (null? empty?)
+ (car head)
+ (cdr dequeue)))
(define empty-queue '())
(define (enqueue q x) (append q (list x)))
- (define empty? null?)
- (define head car)
- (define dequeue cdr) )
+ ;(define empty? null?)
+ ;(define head car)
+ ;(define dequeue cdr)
+ )
-(module queue2 ((interface: QUEUE))
- (import scheme chicken)
+(module queue2 QUEUE
+ (import (rename scheme (not empty?))
+ chicken)
(define-record entry q x)
(define empty-queue #f)
(define enqueue make-entry)
- (define empty? not)
+ ;(define empty? not)
(define (head q)
(let ((q2 (entry-q q)))
(if (empty? q2) (entry-x q) (head q2))))
@@ -28,7 +36,7 @@
(if (empty? q2) empty-queue (make-queue (dequeue q) x)))) )
-(module queue3 ((interface: QUEUE))
+(module queue3 QUEUE
(import scheme chicken)
(define-record queue heads tails)
(define empty-queue (make-queue '() '()))
@@ -53,7 +61,6 @@
(import (rename test-q2 (list->queue l2q2) (queue->list q2l2)))
(import (rename test-q3 (list->queue l2q3) (queue->list q2l3)))
-(use srfi-1)
(define long-list (list-tabulate 10000 identity))
(print "Queue representation #1:")
@@ -64,7 +71,6 @@
(time (q2l3 (q2l3 long-list)))
(module breadth = (breadth-first queue3))
-
(import breadth)
(define (next-char lst)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index a0c3e5f9..2e730e6d 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -145,6 +145,18 @@ $interpret -s reexport-m2.scm
$compile reexport-m2.scm
./a.out
+echo "======================================== functor tests ..."
+$interpret -bnq simple-functors-test.scm
+$compile simple-functors-test.scm
+./a.out
+$interpret -bnq functor-tests.scm
+$compile -bnq functor-tests.scm
+./a.out
+$compile -s square-functor.scm -J
+$compile -s square-functor.import.scm
+$compile run-square-functor.scm
+./a.out
+
echo "======================================== compiler syntax tests ..."
$compile compiler-syntax-tests.scm
./a.out
diff --git a/tests/simple-functors-test.scm b/tests/simple-functors-test.scm
index c1dee7c9..11f01776 100644
--- a/tests/simple-functors-test.scm
+++ b/tests/simple-functors-test.scm
@@ -1,9 +1,9 @@
;;;; simple-functors-test.scm
-(define-interface stuff (a b))
+(define-interface STUFF (a b))
-(module foo ((interface: stuff))
+(module foo ((interface: STUFF)) ; test long spec
(import scheme)
(define a 1)
(define b 2))
@@ -11,7 +11,7 @@
(module f = foo)
(functor
- (do-things (arg ((interface: stuff)))) (do-it)
+ (do-things (arg STUFF)) (do-it)
(import scheme arg)
(define (do-it) (list a b)))
diff --git a/tests/square-functor.scm b/tests/square-functor.scm
new file mode 100644
index 00000000..37b04199
--- /dev/null
+++ b/tests/square-functor.scm
@@ -0,0 +1,5 @@
+;;;; square-functor.scm
+
+(functor (square-functor (M (*))) *
+ (import scheme M)
+ (define (square x) (* x x)))
diff --git a/tests/use-square-functor.scm b/tests/use-square-functor.scm
new file mode 100644
index 00000000..439e356a
--- /dev/null
+++ b/tests/use-square-functor.scm
@@ -0,0 +1,15 @@
+;;; use-square-functor.scm
+
+(import square-functor)
+
+(module num (*) (import scheme))
+(module lst (*) (import (except scheme *)) (define (* x y) (list x y)))
+
+(module sf1 = (square-functor num))
+(module sf2 = (square-functor lst))
+
+(import (prefix sf1 sf1:))
+(import (prefix sf2 sf2:))
+
+(assert (= 9 (sf1:square 3)))
+(assert (equal? '(3 3) (sf2:square 3)))
Trap