On Oct 12 2023, 08:00 UTC, Pietro Cerutti <g...@gahr.ch> wrote:
I haven't tackled (module NAME = FUNCTORNAME BODY ...) yet, but I can
do that if there's consensus on this first part.
As it turns out, this was already trivially matched by the regular
module definition form: ('module name _ . body).
I've added an alternative clause to make it explicit that we're matching
the functor instantiation form, and to avoid recursively scanning the
functor name.
The updated patch and set of example files is attached. The
instantiations of the binop functor rely on this form.
--
Pietro Cerutti
I have pledged to give 10% of income to effective charities
and invite you to join me - https://givingwhatwecan.org
Index: csm.scm
===================================================================
--- csm.scm (revision 42977)
+++ csm.scm (working copy)
@@ -80,6 +80,7 @@
(define programs '())
(define dry-run #f)
(define *mod* #f)
+(define *functor-params* '())
(define *r7rs* #f)
(define *imports* #f)
(define *fname* #f)
@@ -119,6 +120,7 @@
(define (read-source fname prefix r7rs)
(fluid-let ((*mod* #f)
+ (*functor-params* '())
(*fname* (path fname prefix))
(*prefix* prefix)
(*r7rs* r7rs)
@@ -158,10 +160,21 @@
(match x
(('cond-expand clauses ...)
(scan-form `(begin ,@(scan-cond-expand clauses))))
- (('module name _ . body)
+ (('functor (name (fparams _) ...) . body)
(when *mod* (fail "multiple module definitions in file ~a" *ctxt*))
+ (set! *functor-params* (map ->string fparams))
(set! *mod* (canonical-name name))
(scan-form `(begin ,@body)))
+ (('module name '= (fname fparams ...))
+ (when *mod* (fail "multiple module definitions in file ~a" *ctxt*))
+ (set! *mod* (canonical-name name))
+ (scan-import fname)
+ (map scan-import fparams))
+ ((or ('module name _ . body)
+ ('module name '= _ . body))
+ (when *mod* (fail "multiple module definitions in file ~a" *ctxt*))
+ (set! *mod* (canonical-name name))
+ (scan-form `(begin ,@body)))
(('define-library name . body)
(when *mod* (fail "multiple library definitions in file ~a" *ctxt*))
(set! *mod* (canonical-name name))
@@ -235,8 +248,9 @@
(((or 'only 'prefix 'except 'rename) imp . _)
(scan-import imp))
(_ (let ((name (canonical-name imp)))
- (push! name *imports*)
- (when syntax (mark-syntax-module name))))))
+ (unless (member name *functor-params* string=)
+ (push! name *imports*)
+ (when syntax (mark-syntax-module name)))))))
(define (path fname #!optional prefix)
(cond ((string-prefix? "/" fname) fname)
(import
(chicken module)
(arith)
(num)
(str))
(module (arith mix) = (arith num str))
(import
(chicken module)
(arith)
(num))
(module (arith num) = (arith num num))
(functor
(arith (M (plus)) (N (minus)))
(add sub)
(import scheme (prefix M m:) (prefix N n:))
(define (add x y) (m:plus x y))
(define (sub x y) (n:minus x y)))
(import
(chicken module)
(arith)
(str))
(module (arith str) = (arith str str))
(import
(chicken module)
(binop))
(module (binop plus) = binop
(import scheme)
(define (op x y) (+ x y)))
(functor
(binop (M (op)))
(op)
(import scheme (prefix M m:))
(define (op x y)
(m:op x y)))
(import
(chicken module)
(binop))
(module (binop times) = binop
(import scheme)
(define (op x y) (* x y)))
(module main ()
(import
(scheme)
(chicken format)
(prefix (arith num) n:)
(prefix (arith str) s:)
(prefix (arith mix) m:)
(prefix (binop plus) bp:)
(prefix (binop times) bt:))
(printf "num add: ~a, sub: ~a~%" (n:add 3 4) (n:sub 3 4))
(printf "str add: ~a, sub: ~a~%" (s:add "3" "4") (s:sub "3" "4"))
(printf "mix add: ~a, sub: ~a~%" (m:add 3 4) (m:sub "3" "4"))
(printf "op plus : ~a~%" (bp:op 3 4))
(printf "op times: ~a~%" (bt:op 3 4)))
(module num (plus minus)
(import scheme)
(define (plus x y) (+ x y))
(define (minus x y) (- x y)))
(module str (plus minus)
(import scheme)
(define (plus x y) (string-append x " + " y))
(define (minus x y) (string-append x " - " y)))
