From ae602c67325243171d838a17b57c66e95ca71254 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 28 Oct 2017 21:00:15 +0200 Subject: [PATCH] Clean up "scheme" module to only contain standard definitions. In order to more tightly control what gets included in the "scheme" (or rnrs[-null]) module, we capture just the standard macro definitions and bind them to ##sys#scheme-macro-environment, which is used in the hardcoded rnrs module definitions in modules.scm. The macros "syntax", "letrec*", "delay-force" and "require-library" are moved to the (chicken base) module, where they belong. Because letrec* uses "check-for-multiple-bindings", the definition of this has been moved to (chicken internal), as well as the "macro-subset" helper procedure, which is used by expand.scm, chicken-syntax.scm and chicken-ffi-syntax.scm. The "cond-expand" macro has been moved to the "initial macro environment", so that it's always available, even inside modules. The macro probably really belongs in (chicken base) analogously to where it lives in r7rs (on the other hand, it also is available as a core subform in the "library" form), but having it initially available makes it much easier to have code that works both in CHICKEN 4 and CHICKEN 5 by using cond-expand to determine which imports to use; for the majority of programs that'll be the only substantial difference between CHICKEN 4 and 5. Tests have been updated to more correctly import only the stuff they truly need from scheme, chicken.base or chicken.module, as the bare "chicken" module is on its way out. --- chicken-ffi-syntax.scm | 5 +- chicken-syntax.scm | 50 +++++++++-- expand.scm | 195 ++++++++++++++-------------------------- internal.scm | 44 +++++++++ library.scm | 19 ++-- modules.scm | 7 +- posix.scm | 4 +- rules.make | 4 +- tests/module-tests-2.scm | 8 +- tests/module-tests-compiled.scm | 2 +- tests/module-tests.scm | 22 ++--- tests/test-chained-modules.scm | 2 +- 12 files changed, 188 insertions(+), 174 deletions(-) diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm index 69808bf2..0b3008c0 100644 --- a/chicken-ffi-syntax.scm +++ b/chicken-ffi-syntax.scm @@ -27,7 +27,7 @@ (declare (unit chicken-ffi-syntax) - (uses data-structures extras) + (uses data-structures extras internal) (disable-interrupts) (fixnum)) @@ -41,6 +41,7 @@ (import chicken.base chicken.format + chicken.internal chicken.string) (include "common-declarations.scm") @@ -312,4 +313,4 @@ (##core#the fixnum #f ,tmp)))))) -(##sys#macro-subset me0))) +(macro-subset me0))) diff --git a/chicken-syntax.scm b/chicken-syntax.scm index a2f3c800..48a84726 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -27,7 +27,7 @@ (declare (unit chicken-syntax) - (uses expand) + (uses expand internal) (disable-interrupts) (fixnum) ) @@ -39,7 +39,7 @@ (no-bound-checks) (no-procedure-checks)) -(import chicken) +(import chicken (chicken internal)) (include "common-declarations.scm") (include "mini-srfi-1.scm") @@ -104,7 +104,7 @@ `((,%else (chicken.condition#signal ,exvar))))))) ,(cadr form)))))) -(##sys#macro-subset me0 ##sys#default-macro-environment))) +(macro-subset me0 ##sys#default-macro-environment))) ;;; type-related syntax @@ -259,7 +259,7 @@ ,(chicken.compiler.scrutinizer#check-and-validate-type t0 'define-type name)))))))))) -(##sys#macro-subset me0 ##sys#default-macro-environment))) +(macro-subset me0 ##sys#default-macro-environment))) ;;; Non-standard macros that provide core/"base" functionality: @@ -380,6 +380,14 @@ `(##core#declare ,@(cdr form))))) (##sys#extend-macro-environment + 'delay-force + '() + (##sys#er-transformer + (lambda (form r c) + (##sys#check-syntax 'delay-force form '(_ _)) + `(##sys#make-promise (##core#lambda () ,(cadr form)))))) + +(##sys#extend-macro-environment 'include '() (##sys#er-transformer (lambda (form r c) @@ -482,6 +490,19 @@ saveds temps)))))))))))) (##sys#extend-macro-environment + 'require-library + '() + (##sys#er-transformer + (lambda (x r c) + `(##core#begin + ,@(map (lambda (x) + (let-values (((name lib _ _ _ _) (##sys#decompose-import x r c 'import))) + (if (not lib) + '(##core#undefined) + `(##core#require ,lib ,(module-requirement name))))) + (cdr x)))))) + +(##sys#extend-macro-environment 'when '() (##sys#er-transformer (lambda (form r c) @@ -505,6 +526,14 @@ (##sys#check-syntax 'set!-values form '(_ lambda-list _)) (##sys#expand-multiple-values-assignment (cadr form) (caddr form))))) +(##sys#extend-macro-environment + 'syntax + '() + (##sys#er-transformer + (lambda (x r c) + (##sys#check-syntax 'syntax x '(_ _)) + `(##core#syntax ,(cadr x))))) + (set! chicken.syntax#define-values-definition (##sys#extend-macro-environment 'define-values '() @@ -612,6 +641,15 @@ ,@body)))))) (##sys#extend-macro-environment + 'letrec* + '() + (##sys#er-transformer + (lambda (x r c) + (##sys#check-syntax 'letrec* x '(_ #((symbol _) 0) . #(_ 1))) + (check-for-multiple-bindings (cadr x) x "letrec*") + `(##core#letrec* ,@(cdr x))))) + +(##sys#extend-macro-environment 'nth-value `((list-ref . scheme#list-ref)) (##sys#er-transformer @@ -1179,7 +1217,7 @@ (lambda (x r c) `(,(r 'begin-for-syntax) (,(r 'require-extension) ,@(cdr x)))))) -(##sys#macro-subset me0 ##sys#default-macro-environment))) +(macro-subset me0 ##sys#default-macro-environment))) ;;; Remaining non-standard macros: @@ -1343,7 +1381,7 @@ (append ##sys#chicken.condition-macro-environment ##sys#chicken.type-macro-environment ##sys#chicken.base-macro-environment - (##sys#macro-subset me0 ##sys#default-macro-environment)))) + (macro-subset me0 ##sys#default-macro-environment)))) ;; register features diff --git a/expand.scm b/expand.scm index b6c763b6..43a567fb 100644 --- a/expand.scm +++ b/expand.scm @@ -32,7 +32,6 @@ (uses internal) (disable-interrupts) (fixnum) - (hide check-for-multiple-bindings) (not inline ##sys#syntax-error-hook ##sys#compiler-syntax-hook)) (module chicken.syntax @@ -169,6 +168,7 @@ (define ##sys#macro-environment (make-parameter '())) +(define ##sys#scheme-macro-environment '()) ; Assigned to below ;; These are all re-assigned by chicken-syntax.scm: (define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm (define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm @@ -960,10 +960,10 @@ ) ; chicken.syntax module -;;; Macro definitions: - (import chicken chicken.blob chicken.syntax chicken.internal) +;;; Macro definitions: + (##sys#extend-macro-environment 'import-syntax '() (##sys#er-transformer @@ -1004,7 +1004,62 @@ (##sys#register-meta-expression `(,(r 'import) ,@(cdr x))) `(##core#elaborationtimeonly (,(r 'import) ,@(cdr x)))))) -;; The "initial" macro environment, containing only import forms + +(##sys#extend-macro-environment + 'cond-expand + '() + (##sys#er-transformer + (lambda (form r c) + (let ((clauses (cdr form))) + (define (err x) + (##sys#error "syntax error in `cond-expand' form" + x + (cons 'cond-expand clauses)) ) + (define (test fx) + (cond ((symbol? fx) (feature? (strip-syntax fx))) + ((not (pair? fx)) (err fx)) + (else + (let ((head (car fx)) + (rest (cdr fx))) + (case (strip-syntax head) + ((and) + (or (eq? rest '()) + (if (pair? rest) + (and (test (car rest)) + (test `(and ,@(cdr rest))) ) + (err fx) ) ) ) + ((or) + (and (not (eq? rest '())) + (if (pair? rest) + (or (test (car rest)) + (test `(or ,@(cdr rest))) ) + (err fx) ) ) ) + ((not) (not (test (cadr fx)))) + (else (err fx)) ) ) ) ) ) + (let expand ((cls clauses)) + (cond ((eq? cls '()) + (##sys#apply + ##sys#error "no matching clause in `cond-expand' form" + (map (lambda (x) (car x)) clauses) ) ) + ((not (pair? cls)) (err cls)) + (else + (let ((clause (car cls)) + (rclauses (cdr cls)) ) + (if (not (pair? clause)) + (err clause) + (let ((id (car clause))) + (cond ((eq? (strip-syntax id) 'else) + (let ((rest (cdr clause))) + (if (eq? rest '()) + '(##core#undefined) + `(##core#begin ,@rest) ) ) ) + ((test id) `(##core#begin ,@(cdr clause))) + (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) ) + +;; The "initial" macro environment, containing only import forms and +;; cond-expand. TODO: Eventually, cond-expand should move to the +;; (chicken base) module to match r7rs. Keeping it in the initial env +;; makes it a whole lot easier to write portable CHICKEN 4 & 5 code. (define ##sys#initial-macro-environment (##sys#macro-environment)) (##sys#extend-macro-environment @@ -1147,6 +1202,9 @@ ;; The chicken.module syntax environment (define ##sys#chicken.module-macro-environment (##sys#macro-environment)) +(set! ##sys#scheme-macro-environment + (let ((me0 (##sys#macro-environment))) + (##sys#extend-macro-environment 'lambda '() @@ -1164,14 +1222,6 @@ `(##core#quote ,(cadr x))))) (##sys#extend-macro-environment - 'syntax - '() - (##sys#er-transformer - (lambda (x r c) - (##sys#check-syntax 'syntax x '(_ _)) - `(##core#syntax ,(cadr x))))) - -(##sys#extend-macro-environment 'if '() (##sys#er-transformer @@ -1230,19 +1280,6 @@ (chicken.syntax#defjam-error form)) `(##core#define-syntax ,head ,body)))))) -(define (check-for-multiple-bindings bindings form loc) - ;; assumes correct syntax - (let loop ((bs bindings) (seen '()) (warned '())) - (cond ((null? bs)) - ((and (memq (caar bs) seen) - (not (memq (caar bs) warned))) - (##sys#warn - (string-append "variable bound multiple times in " loc " construct") - (caar bs) - form) - (loop (cdr bs) seen (cons (caar bs) warned))) - (else (loop (cdr bs) (cons (caar bs) seen) warned))))) - (##sys#extend-macro-environment 'let '() @@ -1257,15 +1294,6 @@ `(##core#let ,@(cdr x))))) (##sys#extend-macro-environment - 'letrec* - '() - (##sys#er-transformer - (lambda (x r c) - (##sys#check-syntax 'letrec* x '(_ #((symbol _) 0) . #(_ 1))) - (check-for-multiple-bindings (cadr x) x "letrec*") - `(##core#letrec* ,@(cdr x))))) - -(##sys#extend-macro-environment 'letrec '() (##sys#er-transformer @@ -1543,107 +1571,16 @@ (##sys#make-promise (##sys#call-with-values (##core#lambda () ,(cadr form)) ##sys#list)))))) -(##sys#extend-macro-environment - 'delay-force - '() - (##sys#er-transformer - (lambda (form r c) - (##sys#check-syntax 'delay-force form '(_ _)) - `(##sys#make-promise (##core#lambda () ,(cadr form)))))) - -(##sys#extend-macro-environment - 'cond-expand - '() - (##sys#er-transformer - (lambda (form r c) - (let ((clauses (cdr form))) - (define (err x) - (##sys#error "syntax error in `cond-expand' form" - x - (cons 'cond-expand clauses)) ) - (define (test fx) - (cond ((symbol? fx) (feature? (strip-syntax fx))) - ((not (pair? fx)) (err fx)) - (else - (let ((head (car fx)) - (rest (cdr fx))) - (case (strip-syntax head) - ((and) - (or (eq? rest '()) - (if (pair? rest) - (and (test (car rest)) - (test `(and ,@(cdr rest))) ) - (err fx) ) ) ) - ((or) - (and (not (eq? rest '())) - (if (pair? rest) - (or (test (car rest)) - (test `(or ,@(cdr rest))) ) - (err fx) ) ) ) - ((not) (not (test (cadr fx)))) - (else (err fx)) ) ) ) ) ) - (let expand ((cls clauses)) - (cond ((eq? cls '()) - (##sys#apply - ##sys#error "no matching clause in `cond-expand' form" - (map (lambda (x) (car x)) clauses) ) ) - ((not (pair? cls)) (err cls)) - (else - (let ((clause (car cls)) - (rclauses (cdr cls)) ) - (if (not (pair? clause)) - (err clause) - (let ((id (car clause))) - (cond ((eq? (strip-syntax id) 'else) - (let ((rest (cdr clause))) - (if (eq? rest '()) - '(##core#undefined) - `(##core#begin ,@rest) ) ) ) - ((test id) `(##core#begin ,@(cdr clause))) - (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) ) - -(##sys#extend-macro-environment - 'require-library - '() - (##sys#er-transformer - (lambda (x r c) - `(##core#begin - ,@(map (lambda (x) - (let-values (((name lib _ _ _ _) (##sys#decompose-import x r c 'import))) - (if (not lib) - '(##core#undefined) - `(##core#require ,lib ,(module-requirement name))))) - (cdr x)))))) - - ;;; syntax-rules (include "synrules.scm") +(macro-subset me0))) -;;; the base macro environment ("scheme", essentially) - -(define (##sys#macro-subset me0 #!optional parent-env) - (let ((se (let loop ((me (##sys#macro-environment))) - (if (or (null? me) (eq? me me0)) - '() - (cons (car me) (loop (cdr me))))))) - (##sys#fixup-macro-environment se parent-env))) - -(define (##sys#fixup-macro-environment se #!optional parent-env) - (let ((se2 (if parent-env (##sys#append se parent-env) se))) - (for-each ; fixup se - (lambda (sdef) - (when (pair? (cdr sdef)) - (set-car! - (cdr sdef) - (if (null? (cadr sdef)) - se2 - (##sys#append (cadr sdef) se2))))) - se) - se)) +;;; the base macro environment (the old "scheme", essentially) +;;; TODO: Remove this (define ##sys#default-macro-environment - (##sys#fixup-macro-environment (##sys#macro-environment))) + (fixup-macro-environment (##sys#macro-environment))) (define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment))) diff --git a/internal.scm b/internal.scm index 3f8c870d..812f77e1 100644 --- a/internal.scm +++ b/internal.scm @@ -43,6 +43,12 @@ ;; Requirement identifier for modules module-requirement + ;;; Check for multiple bindings in "let"-style constructs + check-for-multiple-bindings + + ;;; Macro environment manipulation + macro-subset fixup-macro-environment + ;; Low-level hash table support hash-table-ref hash-table-set! hash-table-update! hash-table-for-each hash-table-size) @@ -112,6 +118,44 @@ (##sys#string-append (##sys#slot id 1) "#"))) +;;; Check for multiple bindings in "let"-style constructs: + +(define (check-for-multiple-bindings bindings form loc) + ;; assumes correct syntax + (let loop ((bs bindings) (seen '()) (warned '())) + (cond ((null? bs)) + ((and (memq (caar bs) seen) + (not (memq (caar bs) warned))) + (##sys#warn + (string-append "variable bound multiple times in " loc " construct") + (caar bs) + form) + (loop (cdr bs) seen (cons (caar bs) warned))) + (else (loop (cdr bs) (cons (caar bs) seen) warned))))) + + +;;; Macro environment manipulation: +(define (macro-subset me0 #!optional parent-env) + (let ((se (let loop ((me (##sys#macro-environment))) + (if (or (null? me) (eq? me me0)) + '() + (cons (car me) (loop (cdr me))))))) + (fixup-macro-environment se parent-env))) + +(define (fixup-macro-environment se #!optional parent-env) + (let ((se2 (if parent-env (##sys#append se parent-env) se))) + (for-each ; fixup se + (lambda (sdef) + (when (pair? (cdr sdef)) + (set-car! + (cdr sdef) + (if (null? (cadr sdef)) + se2 + (##sys#append (cadr sdef) se2))))) + se) + se)) + + ;;; Low-level hashtable support: (define hash-symbol diff --git a/library.scm b/library.scm index a95bd195..425b36d3 100644 --- a/library.scm +++ b/library.scm @@ -193,9 +193,7 @@ EOF ;; workaround available: we import r5rs-null which contains only the ;; syntactic definitions from r5rs and reexport it straight away in ;; this file, so that we may use at least the scheme definitions -;; normally. For other modules, this still is a major TODO! Also, the -;; scheme module contains too many syntactic definitions, which is -;; also a TODO. +;; normally. For other modules, this still is a major TODO! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Pre-declaration of scheme, so it can be used later on. We only use @@ -209,12 +207,9 @@ EOF ;; We are reexporting these because otherwise the module here ;; will be inconsistent with the built-in one, and be void of ;; syntax definitions, causing problems below. - lambda quote syntax if begin define define-syntax - let letrec letrec* let-syntax letrec-syntax set! and or cond - case let* do quasiquote delay - ;; TODO: Better control the set of macros exported by "scheme" - ;; The following are not standard macros! - delay-force cond-expand require-library syntax-rules + begin and case cond define define-syntax delay do lambda + if let let* let-syntax letrec letrec-syntax or + quasiquote quote set! syntax-rules not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar @@ -567,10 +562,10 @@ EOF (module chicken.base (;; [syntax] and-let* case-lambda cut cute declare define-constant ;; define-inline define-record define-record-type - ;; define-record-printer define-values fluid-let include - ;; include-relative let-optionals let-values let*-values + ;; define-record-printer define-values delay-force fluid-let include + ;; include-relative let-optionals let-values let*-values letrec* ;; letrec-values nth-value optional parameterize rec receive - ;; set!-values unless when use require-library require-extension + ;; require-library require-extension set!-values syntax unless when bignum? flonum? fixnum? ratnum? cplxnum? finite? infinite? nan? exact-integer? exact-integer-sqrt exact-integer-nth-root diff --git a/modules.scm b/modules.scm index 148e8f55..c1895127 100644 --- a/modules.scm +++ b/modules.scm @@ -1027,12 +1027,7 @@ (scheme-report-environment . chicken.eval#scheme-report-environment) (null-environment . chicken.eval#null-environment) (interaction-environment . chicken.eval#interaction-environment))) - (r4rs-syntax - ;;XXX better would be to move these into the "chicken" - ;; module. "import[-for-syntax]" and "reexport" are in - ;; ##sys#initial-macro-environment and thus always available inside - ;; modules. - ##sys#default-macro-environment)) + (r4rs-syntax ##sys#scheme-macro-environment)) (##sys#register-core-module 'r4rs 'library r4rs-values r4rs-syntax) (##sys#register-core-module 'scheme 'library diff --git a/posix.scm b/posix.scm index 225da032..96411355 100644 --- a/posix.scm +++ b/posix.scm @@ -99,7 +99,9 @@ (include "posixwin.scm")))) (module chicken.errno * -(import scheme chicken) +(import scheme + (only chicken errno) + (chicken module)) (export errno) (define errno/2big _e2big) (define errno/acces _eacces) diff --git a/rules.make b/rules.make index b3799667..7b6461d6 100644 --- a/rules.make +++ b/rules.make @@ -608,6 +608,7 @@ compiler-syntax.c: compiler-syntax.scm mini-srfi-1.scm \ chicken.format.import.scm chicken-ffi-syntax.c: chicken-ffi-syntax.scm \ chicken.format.import.scm \ + chicken.internal.import.scm \ chicken.string.import.scm support.c: support.scm mini-srfi-1.scm \ chicken.bitwise.import.scm \ @@ -714,7 +715,8 @@ chicken-uninstall.c: chicken-uninstall.scm \ chicken.posix.import.scm \ chicken.string.import.scm chicken-syntax.c: chicken-syntax.scm \ - chicken.platform.import.scm + chicken.platform.import.scm \ + chicken.internal.import.scm srfi-4.c: srfi-4.scm \ chicken.bitwise.import.scm \ chicken.foreign.import.scm \ diff --git a/tests/module-tests-2.scm b/tests/module-tests-2.scm index be9eed76..0849ca91 100644 --- a/tests/module-tests-2.scm +++ b/tests/module-tests-2.scm @@ -2,7 +2,7 @@ (module oo (output-of) - (import scheme chicken port) + (import scheme port) (define-syntax output-of (syntax-rules () ((_ exp) (with-output-to-string (lambda () exp))))) @@ -10,7 +10,7 @@ (module mscheme (lambda) (import (rename scheme (lambda s:lambda)) - chicken) + (chicken module)) (reexport (except scheme lambda)) (define-syntax lambda (syntax-rules () @@ -66,7 +66,7 @@ ) (module mtest2 (f3 f4) - (import (except scheme lambda) m1 chicken oo) + (import (except scheme lambda) m1 (only chicken assert) oo) (define (f3) ; standard lambda (display 'f3) @@ -91,7 +91,7 @@ (module m3 () (import (rename scheme (define s:define))) - (import chicken) + (import (only chicken assert)) (define-syntax define (syntax-rules () ((_) (display 'oink)))) diff --git a/tests/module-tests-compiled.scm b/tests/module-tests-compiled.scm index 09b2e94c..892d2a22 100644 --- a/tests/module-tests-compiled.scm +++ b/tests/module-tests-compiled.scm @@ -12,7 +12,7 @@ ;; inline func unrecognizable for canonicalizer. (module m1 (f1) - (import scheme chicken) + (import scheme (chicken base)) (define-inline (bar x) (cons x '(foo))) (define-syntax s1 (syntax-rules () diff --git a/tests/module-tests.scm b/tests/module-tests.scm index a1df5dcf..e972db9b 100644 --- a/tests/module-tests.scm +++ b/tests/module-tests.scm @@ -159,7 +159,7 @@ 1) (module m14 (test-extlambda) - (import chicken scheme) + (import scheme) (define (test-extlambda string #!optional whatever) string)) @@ -246,13 +246,13 @@ (module m22 * - (import chicken scheme) + (import scheme) (define b 2)) (module m23 * - (import chicken scheme) + (import (chicken module)) (import m22) (export b) ) @@ -266,16 +266,16 @@ ;; (contributed by "megane") (module m25 * - (import chicken scheme) + (import scheme) (define foo 1)) (module m26 (bar) - (import chicken scheme) + (import (chicken module) scheme) (reexport m25) (define bar 2)) (module m27 * - (import chicken scheme) + (import (chicken module) scheme) (reexport m25) ;; <- oops, bar not exported anymore (define bar 2)) @@ -294,21 +294,21 @@ ;; somewhat related, but with syntax (#882, found by megane): (module m29 * - (import chicken scheme) + (import (chicken syntax) scheme) (define-syntax m29-baz (er-macro-transformer (lambda _ ''foo)))) (module m30 * - (import chicken scheme) + (import (chicken module)) (import m29) (export m29-baz)) (test-equal "star-export with explicit re-export of syntax" (module m31 () - (import scheme chicken) + (import scheme) (import m30) (m29-baz)) 'foo) @@ -333,7 +333,7 @@ ;; Module instantion does not create multiple variable copies. (module m31 * - (import chicken scheme) + (import (chicken base) scheme) (define mutation-count 0) (define (internally-mutate!) (set! mutation-count (add1 mutation-count))) @@ -341,7 +341,7 @@ mutation-count)) (module m32 * - (import chicken scheme m31) + (import (chicken base) scheme m31) (define (externally-mutate!) (set! mutation-count (add1 mutation-count)))) diff --git a/tests/test-chained-modules.scm b/tests/test-chained-modules.scm index 0e67445f..c278f3bd 100644 --- a/tests/test-chained-modules.scm +++ b/tests/test-chained-modules.scm @@ -1,5 +1,5 @@ (module m1 ((s1 f1)) - (import scheme chicken) + (import scheme (chicken base)) (define (f1) (print "f1") 'f1) (define-syntax s1 (syntax-rules () -- 2.11.0