~ chicken-core (master) /expand.scm
Trap1;;;; expand.scm - The HI/LO expander2;3; Copyright (c) 2008-2022, The CHICKEN Team4; All rights reserved.5;6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following7; conditions are met:8;9; Redistributions of source code must retain the above copyright notice, this list of conditions and the following10; disclaimer.11; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following12; disclaimer in the documentation and/or other materials provided with the distribution.13; Neither the name of the author nor the names of its contributors may be used to endorse or promote14; products derived from this software without specific prior written permission.15;16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE24; POSSIBILITY OF SUCH DAMAGE.252627;; this unit needs the "modules" unit, but must be initialized first, so it doesn't28;; declare "modules" as used - if you use "-explicit-use", take care of this.2930(declare31 (unit expand)32 (uses internal)33 (disable-interrupts)34 (fixnum)35 (not inline ##sys#syntax-error-hook ##sys#compiler-syntax-hook))3637(module chicken.syntax38 (expand39 get-line-number40 read-with-source-info41 strip-syntax42 er-macro-transformer43 ir-macro-transformer)4445(import scheme46 chicken.base47 chicken.condition48 chicken.fixnum49 chicken.internal50 chicken.keyword51 chicken.platform52 chicken.string)53(import (only (scheme base) make-parameter open-output-string get-output-string))5455(include "common-declarations.scm")56(include "mini-srfi-1.scm")5758(define-syntax d (syntax-rules () ((_ . _) (void))))59;(define-syntax d (syntax-rules () ((_ args ...) (print args ...))))6061;; Macro to avoid "unused variable map-se" when "d" is disabled62(define-syntax map-se63 (syntax-rules ()64 ((_ ?se)65 (map (lambda (a)66 (cons (car a) (if (symbol? (cdr a)) (cdr a) '<macro>)))67 ?se))))6869(define-alias dd d)70(define-alias dm d)71(define-alias dx d)7273(define-inline (getp sym prop)74 (##core#inline "C_i_getprop" sym prop #f))7576(define-inline (putp sym prop val)77 (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val))7879(define-inline (namespaced-symbol? sym)80 (##core#inline "C_u_i_namespaced_symbolp" sym))8182;;; Source file tracking8384(define ##sys#current-source-filename #f)8586;;; Syntactic environments8788(define ##sys#current-environment (make-parameter '()))89(define ##sys#current-meta-environment (make-parameter '()))9091(define (lookup id se)92 (cond ((##core#inline "C_u_i_assq" id se) => cdr)93 ((getp id '##core#macro-alias))94 (else #f)))9596(define (macro-alias var se)97 (if (or (keyword? var) (namespaced-symbol? var))98 var99 (let* ((alias (gensym var))100 (ua (or (lookup var se) var))101 (rn (or (getp var '##core#real-name) var)))102 (putp alias '##core#macro-alias ua)103 (putp alias '##core#real-name rn)104 (dd "aliasing " alias " (real: " var ") to "105 (if (pair? ua)106 '<macro>107 ua))108 alias) ) )109110(define (strip-syntax exp)111 (let ((seen '()))112 (let walk ((x exp))113 (cond ((assq x seen) => cdr)114 ((keyword? x) x)115 ((symbol? x)116 (let ((x2 (getp x '##core#macro-alias) ) )117 (cond ((getp x '##core#real-name))118 ((not x2) x)119 ((pair? x2) x)120 (else x2))))121 ((pair? x)122 (let ((cell (cons #f #f)))123 (set! seen (cons (cons x cell) seen))124 (set-car! cell (walk (car x)))125 (set-cdr! cell (walk (cdr x)))126 cell))127 ((vector? x)128 (let* ((len (##sys#size x))129 (vec (make-vector len)))130 (set! seen (cons (cons x vec) seen))131 (do ((i 0 (fx+ i 1)))132 ((fx>= i len) vec)133 (##sys#setslot vec i (walk (##sys#slot x i))))))134 (else x)))))135136(define (##sys#extend-se se vars #!optional (aliases (map gensym vars)))137 (for-each138 (lambda (alias sym)139 (let ((original-real-name (getp sym '##core#real-name)))140 (putp alias '##core#real-name (or original-real-name sym))))141 aliases vars)142 (append (map (lambda (x y) (cons x y)) vars aliases) se)) ; inline cons143144145;;; Macro handling146147(define ##sys#macro-environment (make-parameter '()))148149(define ##sys#scheme-macro-environment '()) ; reassigned below150;; These are all re-assigned by chicken-syntax.scm:151(define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm152(define ##sys#chicken.condition-macro-environment '()) ; used later in chicken.condition.import.scm153(define ##sys#chicken.time-macro-environment '()) ; used later in chicken.time.import.scm154(define ##sys#chicken.type-macro-environment '()) ; used later in chicken.type.import.scm155(define ##sys#chicken.syntax-macro-environment '()) ; used later in chicken.syntax.import.scm156(define ##sys#chicken.base-macro-environment '()) ; used later in chicken.base.import.scm157158(define (##sys#ensure-transformer t #!optional loc)159 (if (##sys#structure? t 'transformer)160 (##sys#slot t 1)161 (##sys#error loc "expected syntax-transformer, but got" t)))162163(define (##sys#extend-macro-environment name se transformer)164 (let ((me (##sys#macro-environment))165 (handler (##sys#ensure-transformer transformer name)))166 (cond ((lookup name me) =>167 (lambda (a)168 (set-car! a se)169 (set-car! (cdr a) handler)170 a))171 (else172 (let ((data (list se handler)))173 (##sys#macro-environment174 (cons (cons name data) me))175 data)))))176177(define (##sys#macro? sym #!optional (senv (##sys#current-environment)))178 (or (let ((l (lookup sym senv)))179 (pair? l))180 (and-let* ((l (lookup sym (##sys#macro-environment))))181 (pair? l))))182183(define (##sys#undefine-macro! name)184 (##sys#macro-environment185 ;; this builds up stack, but isn't used often anyway...186 (let loop ((me (##sys#macro-environment)))187 (cond ((null? me) '())188 ((eq? name (caar me)) (cdr me))189 (else (cons (car me) (loop (cdr me))))))))190191;; The basic macro-expander192193(define (##sys#expand-0 exp dse cs?)194 (define (call-handler name handler exp se cs)195 (dd "invoking macro: " name)196 (dd `(STATIC-SE: ,@(map-se se)))197 (handle-exceptions ex198 ;; modify error message in condition object to include199 ;; currently expanded macro-name200 (abort201 (if (and (##sys#structure? ex 'condition)202 (memv 'exn (##sys#slot ex 1)) )203 (##sys#make-structure204 'condition205 (##sys#slot ex 1)206 (let copy ([ps (##sys#slot ex 2)])207 (if (null? ps)208 '()209 (let ([p (car ps)]210 [r (cdr ps)])211 (if (and (equal? '(exn . message) p)212 (pair? r)213 (string? (car r)) )214 (cons215 '(exn . message)216 (cons (string-append217 "during expansion of ("218 (##sys#symbol->string/shared name)219 " ...) - "220 (car r) )221 (cdr r) ) )222 (copy r) ) ) ) ) )223 ex) )224 (let ((exp2225 (if cs226 ;; compiler-syntax may "fall through"227 (fluid-let ((chicken.internal.syntax-rules#syntax-rules-mismatch228 (lambda (input) exp))) ; a bit of a hack229 (handler exp se dse))230 (handler exp se dse))) )231 (when (and (not cs) (eq? exp exp2))232 (##sys#syntax-error233 (string-append234 "syntax transformer for `" (##sys#symbol->string/shared name)235 "' returns original form, which would result in endless expansion")236 exp))237 (dx `(,name ~~> ,exp2))238 (expansion-result-hook exp exp2) ) ) )239 (define (expand head exp mdef)240 (dd `(EXPAND:241 ,head242 ,(cond ((getp head '##core#macro-alias) =>243 (lambda (a) (if (symbol? a) a '<macro>)) )244 (else '_))245 ,exp246 ,(if (pair? mdef)247 `(SE: ,@(map-se (car mdef)))248 mdef)))249 (if (pair? mdef)250 (values251 ;; force ref. opaqueness by passing dynamic se [what does this comment mean? I forgot ...]252 (call-handler head (cadr mdef) exp (car mdef) #f)253 #t)254 (values exp #f)) )255 (let loop ((exp exp))256 (if (pair? exp)257 (let ((head (car exp))258 (body (cdr exp)) )259 (if (symbol? head)260 (let ((head2 (or (lookup head dse) head)))261 (unless (pair? head2)262 (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )263 (cond ((and (pair? head2)264 (eq? (##sys#get head '##sys#override) 'value))265 (values exp #f))266 ((eq? head2 '##core#let)267 (##sys#check-syntax 'let body '#(_ 2) #f dse)268 (let ((bindings (car body)))269 (cond ((symbol? bindings) ; expand named let270 (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)271 (let ([bs (cadr body)])272 (values273 `(##core#app274 (##core#letrec*275 ([,bindings276 (##core#loop-lambda277 ,(map (lambda (b) (car b)) bs) ,@(cddr body))])278 ,bindings)279 ,@(##sys#map cadr bs) )280 #t) ) )281 (else (values exp #f)) ) ) )282 ((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) =>283 (lambda (cs)284 (let ((result (call-handler head (car cs) exp (cdr cs) #t)))285 (cond ((eq? result exp) (expand head exp head2))286 (else287 (when ##sys#compiler-syntax-hook288 (##sys#compiler-syntax-hook head2 result))289 (loop result))))))290 (else (expand head exp head2)) ) )291 (values exp #f) ) )292 (values exp #f) ) ) )293294(define ##sys#compiler-syntax-hook #f)295(define ##sys#enable-runtime-macros #f)296(define expansion-result-hook (lambda (input output) output))297298299;;; User-level macroexpansion300301(define (expand exp #!optional (se (##sys#current-environment)) cs?)302 (let loop ((exp exp))303 (let-values (((exp2 m) (##sys#expand-0 exp se cs?)))304 (if m305 (loop exp2)306 exp2) ) ) )307308309;;; Extended (DSSSL-style) lambda lists310;311; Assumptions:312;313; 1) #!rest must come before #!key314; 2) default values may refer to earlier variables315; 3) optional/key args may be either variable or (variable default)316; 4) an argument marker may not be specified more than once317; 5) no special handling of extra keywords (no error)318; 6) default value of optional/key args is #f319; 7) mixing with dotted list syntax is allowed320321(define (##sys#extended-lambda-list? llist)322 (let loop ([llist llist])323 (and (pair? llist)324 (case (##sys#slot llist 0)325 [(#!rest #!optional #!key) #t]326 [else (loop (cdr llist))] ) ) ) )327328(define ##sys#expand-extended-lambda-list329 (let ((reverse reverse))330 (lambda (llist0 body errh se)331 (define (err msg) (errh msg llist0))332 (define (->keyword s) (string->keyword (##sys#symbol->string/shared s)))333 (let ((rvar #f)334 (hasrest #f)335 ;; These might not exist in se, use default or chicken env:336 (%let* (macro-alias 'let* ##sys#default-macro-environment))337 (%lambda '##core#lambda)338 (%opt (macro-alias 'optional ##sys#chicken.base-macro-environment))339 (%let-optionals* (macro-alias 'let-optionals* ##sys#chicken.base-macro-environment))340 (%let '##core#let))341 (let loop ([mode 0] ; req=0, opt=1, rest=2, key=3, end=4342 [req '()]343 [opt '()]344 [key '()]345 [llist llist0] )346 (cond [(null? llist)347 (values348 (if rvar (##sys#append (reverse req) rvar) (reverse req))349 (let ([body350 (if (null? key)351 body352 `((,%let*353 ,(map (lambda (k)354 (let ((s (car k)))355 `(,s (##sys#get-keyword356 (##core#quote ,(->keyword (strip-syntax s))) ,(or hasrest rvar)357 ,@(if (pair? (cdr k))358 `((,%lambda () ,@(cdr k)))359 '())))))360 (reverse key) )361 ,@body) ) ) ] )362 (cond [(null? opt) body]363 [(and (not hasrest) (null? key) (null? (cdr opt)))364 `((,%let365 ([,(caar opt) (,%opt ,rvar ,(cadar opt))])366 ,@body) ) ]367 [(and (not hasrest) (null? key))368 `((,%let-optionals*369 ,rvar ,(reverse opt) ,@body))]370 [else371 `((,%let-optionals*372 ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar)))373 ,@body))] ) ) ) ]374 [(symbol? llist)375 (if (fx> mode 2)376 (err "rest argument list specified more than once")377 (begin378 (unless rvar (set! rvar llist))379 (set! hasrest llist)380 (loop 4 req opt '() '()) ) ) ]381 [(not (pair? llist))382 (err "invalid lambda list syntax") ]383 [else384 (let* ((var (car llist))385 (x (or (and (symbol? var) (not (eq? 3 mode)) (lookup var se)) var))386 (r (cdr llist)))387 (case x388 [(#!optional)389 (unless rvar (set! rvar (macro-alias 'rest se)))390 (if (eq? mode 0)391 (loop 1 req '() '() r)392 (err "`#!optional' argument marker in wrong context") ) ]393 [(#!rest)394 (if (fx<= mode 1)395 (if (and (pair? r) (symbol? (car r)))396 (begin397 (if (not rvar) (set! rvar (car r)))398 (set! hasrest (car r))399 (loop 2 req opt '() (cdr r)) )400 (err "invalid syntax of `#!rest' argument") )401 (err "`#!rest' argument marker in wrong context") ) ]402 [(#!key)403 (if (not rvar) (set! rvar (macro-alias 'rest se)))404 (if (fx<= mode 2)405 (loop 3 req opt '() r)406 (err "`#!key' argument marker in wrong context") ) ]407 [else408 (cond [(symbol? var)409 (case mode410 [(0) (loop 0 (cons var req) '() '() r)]411 [(1) (loop 1 req (cons (list var #f) opt) '() r)]412 [(2) (err "invalid lambda list syntax after `#!rest' marker")]413 [else (loop 3 req opt (cons (list var) key) r)] ) ]414 [(and (list? var) (eq? 2 (length var)) (symbol? (car var)))415 (case mode416 [(0) (err "invalid required argument syntax")]417 [(1) (loop 1 req (cons var opt) '() r)]418 [(2) (err "invalid lambda list syntax after `#!rest' marker")]419 [else (loop 3 req opt (cons var key) r)] ) ]420 [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )421422423;;; Error message for redefinition of currently used defining form424;425; (i.e.`"(define define ...)")426427(define (defjam-error form)428 (##sys#syntax-error429 "redefinition of currently used defining form" ; help me find something better430 form))431432;;; Expansion of multiple values assignments.433;434; Given a lambda list and a multi-valued expression, returns a form that435; will `set!` each variable to its corresponding value in order.436437(define (##sys#expand-multiple-values-assignment formals expr)438 (##sys#decompose-lambda-list439 formals440 (lambda (vars argc rest)441 (let ((aliases (if (symbol? formals) '() (map gensym formals)))442 (rest-alias (if (not rest) '() (gensym rest))))443 `(##sys#call-with-values444 (##core#lambda () ,expr)445 (##core#lambda446 ,(append aliases rest-alias)447 ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases)448 ,@(cond449 ((null? formals) '((##core#undefined)))450 ((null? rest-alias) '())451 (else `((##core#set! ,rest ,rest-alias))))))))))452453;;; Expansion of bodies (and internal definitions)454;455; This code is disgustingly complex.456457(define define-definition)458(define define-syntax-definition)459(define define-values-definition)460(define import-definition)461462(define ##sys#canonicalize-body463 (lambda (body #!optional (se (##sys#current-environment)) cs?)464 (define (comp s id)465 (let ((f (or (lookup id se)466 (lookup id (##sys#macro-environment)))))467 (and (or (not (symbol? f))468 (not (eq? (##sys#get id '##sys#override) 'value)))469 (or (eq? f s) (eq? s id)))))470 (define (comp-def def)471 (lambda (id)472 (let repeat ((id id))473 (let ((f (or (lookup id se)474 (lookup id (##sys#macro-environment)))))475 (and (or (not (symbol? f))476 (not (eq? (##sys#get id '##sys#override) 'value)))477 (or (eq? f def)478 (and (symbol? f)479 (not (eq? f id))480 (repeat f))))))))481 (define comp-define (comp-def define-definition))482 (define comp-define-syntax (comp-def define-syntax-definition))483 (define comp-define-values (comp-def define-values-definition))484 (define comp-import (comp-def import-definition))485 (define (fini vars vals mvars body)486 (if (and (null? vars) (null? mvars))487 ;; Macro-expand body, and restart when defines are found.488 (let loop ((body body) (exps '()))489 (if (not (pair? body))490 (cons491 '##core#begin492 (reverse exps)) ; no more defines, otherwise we would have called `expand'493 (let loop2 ((body body))494 (let ((x (car body))495 (rest (cdr body)))496 (if (and (pair? x)497 (let ((d (car x)))498 (and (symbol? d)499 (or (comp '##core#begin d)500 (comp-define d)501 (comp-define-values d)502 (comp-define-syntax d)503 (comp-import d)))))504 ;; Stupid hack to avoid expanding imports505 (if (comp-import (car x))506 (loop rest (cons x exps))507 (cons508 '##core#begin509 (##sys#append (reverse exps) (list (expand body)))))510 (let ((x2 (##sys#expand-0 x se cs?)))511 (if (eq? x x2)512 ;; Modules and includes must be processed before513 ;; we can continue with other forms, so hand514 ;; control back to the compiler515 (if (and (pair? x)516 (symbol? (car x))517 (or (comp '##core#module (car x))518 (comp '##core#include (car x))))519 `(##core#begin520 ,@(reverse exps)521 ,@(if (comp '##core#module (car x))522 (if (null? rest)523 `(,x)524 `(,x (##core#let () ,@rest)))525 `((##core#include ,@(cdr x) ,rest))))526 (loop rest (cons x exps)))527 (loop2 (cons x2 rest)) )) ))) ))528 ;; We saw defines. Translate to letrec, and let compiler529 ;; call us again for the remaining body by wrapping the530 ;; remaining body forms in a ##core#let.531 (let* ((result532 `(##core#let533 ,(##sys#map534 (lambda (v) (##sys#list v '(##core#undefined)))535 ;; vars are all normalised to lambda-lists: flatten them536 (foldl (lambda (l v)537 (##sys#append l (##sys#decompose-lambda-list538 v (lambda (a _ _) a))))539 '()540 (reverse vars))) ; not strictly necessary...541 ,@(map (lambda (var val is-mvar?)542 ;; Non-mvars should expand to set! for543 ;; efficiency, but also because they must be544 ;; implicit multi-value continuations.545 (if is-mvar?546 (##sys#expand-multiple-values-assignment var val)547 `(##core#set! ,(car var) ,val)))548 (reverse vars)549 (reverse vals)550 (reverse mvars))551 ,@body) ) )552 (dd `(BODY: ,result))553 result)))554 (define (fini/syntax vars vals mvars body)555 (fini556 vars vals mvars557 (let loop ((body body) (defs '()) (done #f))558 (cond (done `((##core#letrec-syntax559 ,(map cdr (reverse defs)) ,@body) ))560 ((not (pair? body)) (loop body defs #t))561 ((and (list? (car body))562 (>= 3 (length (car body)))563 (symbol? (caar body))564 (comp-define-syntax (caar body)))565 (let ((def (car body)))566 ;; This check is insufficient, if introduced by567 ;; different expansions, but better than nothing:568 (when (eq? (car def) (cadr def))569 (defjam-error def))570 (loop (cdr body) (cons def defs) #f)))571 (else (loop body defs #t))))))572 ;; Expand a run of defines or define-syntaxes into letrec. As573 ;; soon as we encounter something else, finish up.574 (define (expand body)575 ;; Each #t in "mvars" indicates an MV-capable "var". Non-MV576 ;; vars (#f in mvars) are 1-element lambda-lists for simplicity.577 (let loop ((body body) (vars '()) (vals '()) (mvars '()))578 (d "BODY: " body)579 (if (not (pair? body))580 (fini vars vals mvars body)581 (let* ((x (car body))582 (rest (cdr body))583 (exp1 (and (pair? x) (car x)))584 (head (and exp1 (symbol? exp1) exp1)))585 (if (not (symbol? head))586 (fini vars vals mvars body)587 (cond588 ((comp-define head)589 (##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)590 (let loop2 ((x x))591 (let ((head (cadr x)))592 (cond ((not (pair? head))593 (##sys#check-syntax 'define x '(_ variable . #(_ 0)) #f se)594 (when (eq? (car x) head) ; see above595 (defjam-error x))596 (loop rest (cons (list head) vars)597 (cons (if (pair? (cddr x))598 (caddr x)599 '(##core#undefined) )600 vals)601 (cons #f mvars)))602 ((pair? (car head))603 (##sys#check-syntax604 'define x '(_ (_ . lambda-list) . #(_ 1)) #f se)605 (loop2606 (chicken.syntax#expand-curried-define head (cddr x) se)))607 (else608 (##sys#check-syntax609 'define x610 '(_ (variable . lambda-list) . #(_ 1)) #f se)611 (loop rest612 (cons (list (car head)) vars)613 (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)614 (cons #f mvars)))))))615 ((comp-define-syntax head)616 (##sys#check-syntax 'define-syntax x '(_ _ . #(_ 1)) se)617 (fini/syntax vars vals mvars body))618 ((comp-define-values head)619 ;;XXX check for any of the variables being `define-values'620 (##sys#check-syntax 'define-values x '(_ lambda-list _) #f se)621 (loop rest (cons (cadr x) vars) (cons (caddr x) vals) (cons #t mvars)))622 ((comp '##core#begin head)623 (loop (##sys#append (cdr x) rest) vars vals mvars))624 (else625 ;; Do not macro-expand local definitions we are626 ;; in the process of introducing.627 (if (member (list head) vars)628 (fini vars vals mvars body)629 (let ((x2 (##sys#expand-0 x se cs?)))630 (if (eq? x x2)631 (fini vars vals mvars body)632 (loop (cons x2 rest) vars vals mvars)))))))))))633 (expand body) ) )634635636;;; A simple expression matcher637638;; Used by "quasiquote", below639(define chicken.syntax#match-expression640 (lambda (exp pat vars)641 (let ((env '()))642 (define (mwalk x p)643 (cond ((not (pair? p))644 (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))645 ((memq p vars)646 (set! env (cons (cons p x) env))647 #t)648 (else (eq? x p)) ) )649 ((pair? x)650 (and (mwalk (car x) (car p))651 (mwalk (cdr x) (cdr p)) ) )652 (else #f) ) )653 (and (mwalk exp pat) env) ) ) )654655656;;; Expand "curried" lambda-list syntax for `define'657658;; Used by "define", below659(define (chicken.syntax#expand-curried-define head body se)660 (let ((name #f))661 (define (loop head body)662 (if (symbol? (car head))663 (begin664 (set! name (car head))665 `(##core#lambda ,(cdr head) ,@body) )666 (loop (car head) `((##core#lambda ,(cdr head) ,@body)) ) ))667 (let ([exp (loop head body)])668 (list 'define name exp) ) ) )669670671;;; Line-number database management:672673(define ##sys#line-number-database #f)674675676;;; General syntax checking routine:677678(define ##sys#syntax-error-culprit #f)679(define ##sys#syntax-context '())680681(define (##sys#syntax-error-hook . args)682 (apply ##sys#signal-hook #:syntax-error683 (strip-syntax args)))684685(define (##sys#syntax-error . args)686 (apply ##sys#syntax-error-hook args))687688(define ##sys#syntax-error/context689 (lambda (msg arg)690 (define (syntax-imports sym)691 (let loop ((defs (or (##sys#get (strip-syntax sym) '##core#db) '())))692 (cond ((null? defs) '())693 ((eq? 'syntax (caar defs))694 (cons (cadar defs) (loop (cdr defs))))695 (else (loop (cdr defs))))))696 (if (null? ##sys#syntax-context)697 (##sys#syntax-error-hook msg arg)698 (let ((out (open-output-string)))699 (define (outstr str)700 (##sys#print str #f out))701 (let loop ((cx ##sys#syntax-context))702 (cond ((null? cx) ; no unimported syntax found703 (outstr msg)704 (outstr ": ")705 (##sys#print arg #t out)706 (outstr "\ninside expression `(")707 (##sys#print (strip-syntax (car ##sys#syntax-context)) #t out)708 (outstr " ...)'"))709 (else710 (let* ((sym (strip-syntax (car cx)))711 (us (syntax-imports sym)))712 (cond ((pair? us)713 (outstr msg)714 (outstr ": ")715 (##sys#print arg #t out)716 (outstr "\n\n Perhaps you intended to use the syntax `(")717 (##sys#print sym #t out)718 (outstr " ...)' without importing it first.\n")719 (if (fx= 1 (length us))720 (outstr721 (string-append722 " Suggesting: `(import "723 (symbol->string (car us))724 ")'"))725 (outstr726 (string-append727 " Suggesting one of:\n"728 (let loop ((lst us))729 (if (null? lst)730 ""731 (string-append732 "\n (import " (symbol->string (car lst)) ")'"733 (loop (cdr lst)))))))))734 (else (loop (cdr cx))))))))735 (##sys#syntax-error-hook (get-output-string out))))))736737;;; Hook for source information738739(define (alist-weak-cons k v lst)740 (cons (##core#inline_allocate ("C_a_i_weak_cons" 3) k v) lst))741742(define (assq/drop-bwp! x lst)743 (let lp ((lst lst)744 (prev #f))745 (cond ((null? lst) #f)746 ((eq? x (caar lst)) (car lst))747 ((and prev748 (##core#inline "C_bwpp" (caar lst)))749 (set-cdr! prev (cdr lst))750 (lp (cdr lst) prev))751 (else (lp (cdr lst) lst)))))752753(define (read-with-source-info-hook class data val)754 (when (and (eq? 'list-info class) (symbol? (car data)))755 (let ((old-value (or (hash-table-ref ##sys#line-number-database (car data)) '())))756 (assq/drop-bwp! (car data) old-value) ;; Hack to clean out garbage values757 (hash-table-set!758 ##sys#line-number-database759 (car data)760 (alist-weak-cons761 data (conc (or ##sys#current-source-filename "<stdin>") ":" val)762 old-value ) )) )763 data)764765(define-constant line-number-database-size 997) ; Copied from core.scm766767(define (read-with-source-info #!optional (in ##sys#standard-input))768 ;; Initialize line number db on first use769 (unless ##sys#line-number-database770 (set! ##sys#line-number-database (make-vector line-number-database-size '())))771 (##sys#check-input-port in #t 'read-with-source-info)772 (##sys#read in read-with-source-info-hook) )773774775(define (get-line-number sexp)776 (and ##sys#line-number-database777 (pair? sexp)778 (let ([head (car sexp)])779 (and (symbol? head)780 (cond ((hash-table-ref ##sys#line-number-database head)781 => (lambda (pl)782 (let ((a (assq/drop-bwp! sexp pl)))783 (and a (cdr a)))))784 (else #f))))))785786;; TODO: Needs a better name - it extracts the name(?) and the source expression787(define (##sys#get-line-2 exp)788 (let* ((name (car exp))789 (lst (hash-table-ref ##sys#line-number-database name)))790 (cond ((and lst (assq/drop-bwp! exp (cdr lst)))791 => (lambda (a) (values (car lst) (cdr a))) )792 (else (values name #f)) ) ) )793794(define (##sys#display-line-number-database)795 (hash-table-for-each796 (lambda (key val)797 (when val798 (let ((port (current-output-port)))799 (##sys#print key #t port)800 (##sys#print " " #f port)801 (##sys#print (map cdr val) #t port)802 (##sys#print "\n" #f port))) )803 ##sys#line-number-database) )804805;;; Traverse expression and update line-number db with all contained calls:806807(define (##sys#update-line-number-database! exp ln)808 (define (mapupdate xs)809 (let loop ((xs xs))810 (when (pair? xs)811 (walk (car xs))812 (loop (cdr xs)) ) ))813 (define (walk x)814 (cond ((not (pair? x)))815 ((symbol? (car x))816 (let* ((name (car x))817 (old (or (hash-table-ref ##sys#line-number-database name) '())))818 (unless (assq x old)819 (hash-table-set! ##sys#line-number-database name (alist-cons x ln old)))820 (when (list? x) (mapupdate (cdr x)) )))821 (else (mapupdate x)) ) )822 (walk exp))823824825(define-constant +default-argument-count-limit+ 99999)826827(define ##sys#check-syntax828 (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))829830 (define (test x pred msg)831 (unless (pred x) (err msg)) )832833 (define (err msg)834 (let* ([sexp ##sys#syntax-error-culprit]835 [ln (get-line-number sexp)] )836 (##sys#syntax-error837 (if ln838 (string-append "(" ln ") in `" (symbol->string id) "' - " msg)839 (string-append "in `" (symbol->string id) "' - " msg) )840 exp) ) )841842 (define (lambda-list? x)843 (or (##sys#extended-lambda-list? x)844 (let loop ((x x))845 (cond ((null? x))846 ((symbol? x))847 ((pair? x)848 (let ((s (car x)))849 (and (symbol? s)850 (loop (cdr x)) ) ) )851 (else #f) ) ) ) )852853 (define (variable? v)854 (symbol? v))855856 (define (proper-list? x)857 (let loop ((x x))858 (cond ((eq? x '()))859 ((pair? x) (loop (cdr x)))860 (else #f) ) ) )861862 (when culprit (set! ##sys#syntax-error-culprit culprit))863 (let walk ((x exp) (p pat))864 (cond ((vector? p)865 (let* ((p2 (vector-ref p 0))866 (vlen (##sys#size p))867 (min (if (fx> vlen 1)868 (vector-ref p 1)869 0) )870 (max (cond ((eq? vlen 1) 1)871 ((fx> vlen 2) (vector-ref p 2))872 (else +default-argument-count-limit+) ) ) )873 (do ((x x (cdr x))874 (n 0 (fx+ n 1)) )875 ((eq? x '())876 (if (fx< n min)877 (err "not enough arguments") ) )878 (cond ((fx>= n max)879 (err "too many arguments") )880 ((not (pair? x))881 (err "not a proper list") )882 (else (walk (car x) p2) ) ) ) ) )883 ((##sys#immediate? p)884 (if (not (eq? p x)) (err "unexpected object")) )885 ((symbol? p)886 (case p887 ((_) #t)888 ((pair) (test x pair? "pair expected"))889 ((variable) (test x variable? "identifier expected"))890 ((symbol) (test x symbol? "symbol expected"))891 ((list) (test x proper-list? "proper list expected"))892 ((number) (test x number? "number expected"))893 ((string) (test x string? "string expected"))894 ((lambda-list) (test x lambda-list? "lambda-list expected"))895 (else896 (test897 x898 (lambda (y)899 (let ((y2 (and (symbol? y) (lookup y se))))900 (eq? (if (symbol? y2) y2 y) p)))901 "missing keyword")) ) )902 ((not (pair? p))903 (err "incomplete form") )904 ((not (pair? x)) (err "pair expected"))905 (else906 (walk (car x) (car p))907 (walk (cdr x) (cdr p)) ) ) ) ) )908909910;;; explicit/implicit-renaming transformer911912(define (make-er/ir-transformer handler explicit-renaming?)913 (##sys#make-structure914 'transformer915 (lambda (form se dse)916 (let ((renv '())) ; keep rename-environment for this expansion917 (define (inherit-pair-line-numbers old new)918 (and-let* ((name (car new))919 ((symbol? name))920 (ln (get-line-number old))921 (cur (or (hash-table-ref ##sys#line-number-database name) '())) )922 (unless (assq new cur)923 (hash-table-set! ##sys#line-number-database name924 (alist-weak-cons new ln cur))))925 new)926 (assert (list? se) "not a list" se) ;XXX remove later927 (define (rename sym)928 (cond ((pair? sym)929 (inherit-pair-line-numbers sym (cons (rename (car sym)) (rename (cdr sym)))))930 ((vector? sym)931 (list->vector (rename (vector->list sym))))932 ((not (symbol? sym)) sym)933 ((assq sym renv) =>934 (lambda (a)935 (dd `(RENAME/RENV: ,sym --> ,(cdr a)))936 (cdr a)))937 (else938 (let ((a (macro-alias sym se)))939 (dd `(RENAME: ,sym --> ,a))940 (set! renv (cons (cons sym a) renv))941 a))))942 (define (compare s1 s2)943 (let ((result944 (cond ((pair? s1)945 (and (pair? s2)946 (compare (car s1) (car s2))947 (compare (cdr s1) (cdr s2))))948 ((vector? s1)949 (and (vector? s2)950 (let ((len (vector-length s1)))951 (and (fx= len (vector-length s2))952 (do ((i 0 (fx+ i 1))953 (f #t (compare (vector-ref s1 i) (vector-ref s2 i))))954 ((or (fx>= i len) (not f)) f))))))955 ((and (symbol? s1)956 (symbol? s2))957 (let ((ss1 (or (getp s1 '##core#macro-alias)958 (lookup2 1 s1 dse)959 s1) )960 (ss2 (or (getp s2 '##core#macro-alias)961 (lookup2 2 s2 dse)962 s2) ) )963 (cond ((symbol? ss1)964 (cond ((symbol? ss2) (eq? ss1 ss2))965 ((assq ss1 (##sys#macro-environment)) =>966 (lambda (a) (eq? (cdr a) ss2)))967 (else #f) ) )968 ((symbol? ss2)969 (cond ((assq ss2 (##sys#macro-environment)) =>970 (lambda (a) (eq? ss1 (cdr a))))971 (else #f)))972 (else (eq? ss1 ss2)))))973 (else (eq? s1 s2))) ) )974 (dd `(COMPARE: ,s1 ,s2 --> ,result))975 result))976 (define (lookup2 n sym dse)977 (let ((r (lookup sym dse)))978 (dd " (lookup/DSE " (list n) ": " sym " --> "979 (if (and r (pair? r))980 '<macro>981 r)982 ")")983 r))984 (define (assq-reverse s l)985 (cond986 ((null? l) #f)987 ((eq? (cdar l) s) (car l))988 (else (assq-reverse s (cdr l)))))989 (define (mirror-rename sym)990 (cond ((pair? sym)991 (inherit-pair-line-numbers992 sym (cons (mirror-rename (car sym)) (mirror-rename (cdr sym)))))993 ((vector? sym)994 (list->vector (mirror-rename (vector->list sym))))995 ((not (symbol? sym)) sym)996 (else ; Code stolen from strip-syntax997 (let ((renamed (lookup sym se) ) )998 (cond ((assq-reverse sym renv) =>999 (lambda (a)1000 (dd "REVERSING RENAME: " sym " --> " (car a)) (car a)))1001 ((not renamed)1002 (dd "IMPLICITLY RENAMED: " sym) (rename sym))1003 ((pair? renamed)1004 (dd "MACRO: " sym) (rename sym))1005 ((getp sym '##core#real-name) =>1006 (lambda (name)1007 (dd "STRIP SYNTAX ON " sym " ---> " name)1008 name))1009 ;; Rename builtin aliases so strip-syntax can still1010 ;; access symbols as entered by the user1011 (else (let ((implicitly-renamed (rename sym)))1012 (dd "BUILTIN ALIAS: " sym " as " renamed1013 " --> " implicitly-renamed)1014 implicitly-renamed)))))))1015 (if explicit-renaming?1016 ;; Let the user handle renaming1017 (handler form rename compare)1018 ;; Implicit renaming:1019 ;; Rename everything in the input first, feed it to the transformer1020 ;; and then swap out all renamed identifiers by their non-renamed1021 ;; versions, and vice versa. User can decide when to inject code1022 ;; unhygienically this way.1023 (mirror-rename (handler (rename form) rename compare)) ) ) )))10241025(define (er-macro-transformer handler) (make-er/ir-transformer handler #t))1026(define (ir-macro-transformer handler) (make-er/ir-transformer handler #f))10271028(define ##sys#er-transformer er-macro-transformer)1029(define ##sys#ir-transformer ir-macro-transformer)103010311032;; Expose some internals for use in core.scm and chicken-syntax.scm:10331034(define chicken.syntax#define-definition define-definition)1035(define chicken.syntax#define-syntax-definition define-syntax-definition)1036(define chicken.syntax#define-values-definition define-values-definition)1037(define chicken.syntax#expansion-result-hook expansion-result-hook)10381039) ; chicken.syntax module10401041(import scheme chicken.base chicken.bytevector chicken.fixnum)1042(import chicken.syntax chicken.internal chicken.platform)1043(import (only (scheme base) make-parameter))10441045;;; Macro definitions:10461047(##sys#extend-macro-environment1048 'import-syntax '()1049 (##sys#er-transformer1050 (cut ##sys#expand-import <> <> <>1051 ##sys#current-environment ##sys#macro-environment1052 #f #f 'import-syntax)))10531054(##sys#extend-macro-environment1055 'import-syntax-for-syntax '()1056 (##sys#er-transformer1057 (cut ##sys#expand-import <> <> <>1058 ##sys#current-meta-environment ##sys#meta-macro-environment1059 #t #f 'import-syntax-for-syntax)))10601061(set! chicken.syntax#import-definition1062 (##sys#extend-macro-environment1063 'import '()1064 (##sys#er-transformer1065 (lambda (x r c)1066 `(##core#begin1067 ,@(map (lambda (x)1068 (let-values (((name lib spec v s i) (##sys#decompose-import x r c 'import))1069 ((mod) (##sys#current-module)))1070 (when (and mod (eq? name (##sys#module-name mod)))1071 (##sys#syntax-error1072 'import "cannot import from module currently being defined" name))1073 (if (not spec)1074 (##sys#syntax-error1075 'import "cannot import from undefined module" name)1076 (##sys#import1077 spec v s i1078 ##sys#current-environment ##sys#macro-environment #f #f 'import))1079 (if (not lib)1080 '(##core#undefined)1081 `(##core#require ,lib ,name))))1082 (cdr x)))))))10831084(##sys#extend-macro-environment1085 'import-for-syntax '()1086 (##sys#er-transformer1087 (lambda (x r c)1088 (##sys#register-meta-expression `(,(r 'import) ,@(cdr x)))1089 `(##core#elaborationtimeonly (,(r 'import) ,@(cdr x))))))10901091(define (process-cond-expand clauses)1092 (define (err x)1093 (##sys#syntax-error "syntax error in `cond-expand' form"1094 x1095 (cons 'cond-expand clauses)))1096 (define (file-exists? fname)1097 (##sys#file-exists? fname #f #f 'cond-expand))1098 (define (locate-library name)1099 (let* ((name2 (library-id name))1100 (sname2 (symbol->string name2)))1101 (or (##sys#find-module name2 #f)1102 (let loop ((rp (repository-path)))1103 (and (pair? rp)1104 (let ((p (car rp)))1105 (or (file-exists? (string-append p "/" sname2 ".import.so"))1106 (file-exists? (string-append p "/" sname2 ".import.scm"))1107 (loop (cdr rp)))))))))1108 (define (test fx)1109 (cond ((symbol? fx) (feature? (strip-syntax fx)))1110 ((not (pair? fx)) (err fx))1111 (else1112 (let ((head (car fx))1113 (rest (cdr fx)))1114 (case (strip-syntax head)1115 ((and)1116 (or (eq? rest '())1117 (if (pair? rest)1118 (and (test (car rest))1119 (test `(and ,@(cdr rest))))1120 (err fx))))1121 ((or)1122 (and (not (eq? rest '()))1123 (if (pair? rest)1124 (or (test (car rest))1125 (test `(or ,@(cdr rest))))1126 (err fx))))1127 ((not) (not (test (cadr fx))))1128 ((library)1129 (if (and (pair? rest)1130 (null? (cdr rest)))1131 (locate-library (strip-syntax (car rest)))1132 (err fx)))1133 (else (err fx)))))))1134 (let expand ((cls clauses))1135 (cond ((eq? cls '())1136 (##sys#apply1137 ##sys#error "no matching clause in `cond-expand' form"1138 (map (lambda (x) (car x)) clauses)))1139 ((not (pair? cls)) (err cls))1140 (else1141 (let ((clause (car cls))1142 (rclauses (cdr cls)))1143 (if (not (pair? clause))1144 (err clause)1145 (let ((id (car clause)))1146 (cond ((eq? (strip-syntax id) 'else)1147 (let ((rest (cdr clause)))1148 (if (eq? rest '())1149 '(##core#undefined)1150 `(##core#begin ,@rest))))1151 ((test id) `(##core#begin ,@(cdr clause)))1152 (else (expand rclauses))))))))))11531154(##sys#extend-macro-environment1155 'cond-expand1156 '()1157 (##sys#er-transformer1158 (lambda (form r c)1159 (process-cond-expand (cdr form)))))11601161;; The "initial" macro environment, containing only import forms and1162;; cond-expand. TODO: Eventually, cond-expand should move to the1163;; (chicken base) module to match r7rs. Keeping it in the initial env1164;; makes it a whole lot easier to write portable CHICKEN 4 & 5 code.1165(define ##sys#initial-macro-environment (##sys#macro-environment))11661167(##sys#extend-macro-environment1168 'module '()1169 (##sys#er-transformer1170 (lambda (x r c)1171 (##sys#check-syntax 'module x '(_ _ _ . #(_ 0)))1172 (let ((len (length x))1173 (name (library-id (cadr x))))1174 ;; We strip syntax here instead of doing a hygienic comparison1175 ;; to "=". This is a tradeoff; either we do this, or we must1176 ;; include a mapping of (= . scheme#=) in our syntax env. In1177 ;; the initial environment, = is bound to scheme#=, but when1178 ;; using -explicit-use that's not the case. Doing an unhygienic1179 ;; comparison ensures module will work in both cases.1180 (cond ((and (fx>= len 4) (eq? '= (strip-syntax (caddr x))))1181 (let* ((x (strip-syntax x))1182 (app (cadddr x)))1183 (cond ((fx> len 4)1184 ;; feature suggested by syn:1185 ;;1186 ;; (module NAME = FUNCTORNAME BODY ...)1187 ;; ~>1188 ;; (begin1189 ;; (module _NAME * BODY ...)1190 ;; (module NAME = (FUNCTORNAME _NAME)))1191 ;;1192 ;; - the use of "_NAME" is a bit stupid, but it must be1193 ;; externally visible to generate an import library from1194 ;; and compiling "NAME" separately may need an import-lib1195 ;; for stuff in "BODY" (say, syntax needed by syntax exported1196 ;; from the functor, or something like this...)1197 (let ((mtmp (string->symbol1198 (##sys#string-append1199 "_"1200 (symbol->string name))))1201 (%module (r 'module)))1202 `(##core#begin1203 (,%module ,mtmp * ,@(cddddr x))1204 (,%module ,name = (,app ,mtmp)))))1205 (else1206 (##sys#check-syntax1207 'module x '(_ _ _ (_ . #(_ 0))))1208 (##sys#instantiate-functor1209 name1210 (library-id (car app))1211 (cdr app)))))) ; functor arguments1212 (else1213 ;;XXX use module name in "loc" argument?1214 (let ((exports (##sys#validate-exports (strip-syntax (caddr x)) 'module)))1215 `(##core#module1216 ,name1217 ,(if (eq? '* exports)1218 #t1219 exports)1220 ,@(let ((body (cdddr x)))1221 (if (and (pair? body)1222 (null? (cdr body))1223 (string? (car body)))1224 `((##core#include ,(car body) ,##sys#current-source-filename))1225 body))))))))))12261227;;; R7RS define-library12281229(##sys#extend-macro-environment1230 'define-library '()1231 (##sys#er-transformer1232 (lambda (x r c)1233 (define (register-r7rs-module name)1234 (let ((dummy (string->symbol (string-append (string #\x04) "r7rs" (symbol->string name)))))1235 (##sys#put! name '##r7rs#module dummy)1236 dummy))1237 (define implicit-r7rs-library-bindings1238 '(begin1239 cond-expand1240 export1241 import1242 import-for-syntax1243 include1244 include-ci1245 syntax-rules))1246 (##sys#check-syntax 'define-library x '(_ . #(_ 0)))1247 (let* ((x (strip-syntax x))1248 (name (cadr x))1249 (real-name (library-id name))1250 (decls (cddr x))1251 (dummy (register-r7rs-module real-name)))1252 (define (parse-exports specs)1253 (map (lambda (spec)1254 (cond ((and (list? spec)1255 (= 3 (length spec))1256 (eq? 'rename (car spec)))1257 `(export/rename ,(cdr spec)))1258 ((symbol? spec) `(export ,spec))1259 (else1260 (##sys#syntax-error 'define-library "invalid export specifier" spec name))))1261 specs))1262 (define (parse-imports specs)1263 ;; XXX TODO: Should be import-for-syntax'ed as well?1264 `(import ,@specs))1265 (define (process-includes fnames ci?)1266 `(##core#begin1267 ,@(map (lambda (fname)1268 (if (string? fname)1269 `(##core#begin ,@(read-forms fname ci?)))1270 (fname (##sys#syntax-error 'include "invalid include-filename" fname)))1271 fnames)))1272 (define (expand/begin e)1273 (let ((e2 (expand e '())))1274 (if (and (pair? e2) (eq? '##core#begin (car e2)))1275 (cons '##core#begin (map expand/begin (cdr e2)))1276 e2)))1277 (define (read-forms filename ci? #!optional (proc (lambda (x) (map expand/begin x))))1278 (fluid-let ((##sys#default-read-info-hook1279 (let ((name 'chicken.compiler.support#read-info-hook))1280 (and (feature? 'compiling)1281 (##sys#symbol-has-toplevel-binding? name)1282 (##sys#slot name 0)))))1283 (##sys#include-forms-from-file1284 filename1285 ##sys#current-source-filename ci?1286 (lambda (forms path) (proc forms)))))1287 (define (process-include-decls fnames)1288 (parse-decls1289 (let loop ((fnames fnames) (all '()))1290 (if (null? fnames)1291 (reverse all)1292 (let ((forms (read-forms (car fnames) #t (lambda (x) x))))1293 (loop (cdr fnames)1294 (append (reverse forms) all)))))))1295 (define (fail spec)1296 (##sys#syntax-error 'define-library "invalid library declaration" spec))1297 (define (parse-decls decls)1298 (cond ((null? decls) '(##core#begin))1299 ((and (pair? decls) (pair? (car decls)))1300 (let ((spec (car decls))1301 (more (cdr decls)))1302 (case (car spec)1303 ((export)1304 (##sys#check-syntax 'export spec '(_ . #(_ 0)))1305 `(##core#begin ,@(parse-exports (cdr spec))1306 ,(parse-decls more)))1307 ((import)1308 (##sys#check-syntax 'import spec '(_ . #(_ 0)))1309 `(##core#begin ,(parse-imports (cdr spec))1310 ,(parse-decls more)))1311 ((include)1312 (##sys#check-syntax 'include spec '(_ . #(_ 0)))1313 `(##core#begin ,(process-includes (cdr spec) #f)1314 ,(parse-decls more)))1315 ((include-ci)1316 (##sys#check-syntax 'include-ci spec '(_ . #(_ 0)))1317 `(##core#begin ,(process-includes (cdr spec) #t)1318 ,(parse-decls more)))1319 ((include-library-declarations)1320 `(##core#begin ,(process-include-decls (cdr spec))1321 ,(parse-decls more)))1322 ((cond-expand)1323 (parse-decls (append (list (process-cond-expand (cdr spec)))1324 more)))1325 ((##core#begin)1326 (parse-decls (cdr spec)))1327 ((begin)1328 `(##core#begin ,@(cdr spec)1329 ,(parse-decls more)))1330 (else (fail spec)))))1331 (else (fail (car decls)))))1332 `(##core#module ,real-name ((,dummy))1333 ;; gruesome hack: we add a dummy export for adding indirect exports1334 (##core#define-syntax ,dummy1335 (##sys#er-transformer (##core#lambda (x r c) (##core#undefined))))1336 ;; Set up an R7RS environment for the module's body.1337 (import-for-syntax (only scheme.base ,@implicit-r7rs-library-bindings))1338 (import (only scheme.base ,@implicit-r7rs-library-bindings)1339 (only chicken.module export/rename))1340 ;; Now process all toplevel library declarations1341 ,(parse-decls decls))))))13421343(##sys#extend-macro-environment1344 'export '()1345 (##sys#er-transformer1346 (lambda (x r c)1347 (let ((exps (##sys#validate-exports (strip-syntax (cdr x)) 'export))1348 (mod (##sys#current-module)))1349 (when mod1350 (##sys#add-to-export-list mod exps))1351 '(##core#undefined)))))13521353(##sys#extend-macro-environment1354 'export/rename '()1355 (##sys#er-transformer1356 (lambda (x r c)1357 (let ((exps (map (lambda (ren)1358 (if (and (pair? ren)1359 (symbol? (car ren))1360 (pair? (cdr ren))1361 (symbol? (cadr ren))1362 (null? (cddr ren)))1363 (cons (car ren) (cadr ren))1364 (##sys#syntax-error "invalid item in export rename list"1365 ren)))1366 (strip-syntax (cdr x))))1367 (mod (##sys#current-module)))1368 (when mod1369 (##sys#add-to-export/rename-list mod exps))1370 '(##core#undefined)))))13711372(##sys#extend-macro-environment1373 'reexport '()1374 (##sys#er-transformer1375 (cut ##sys#expand-import <> <> <>1376 ##sys#current-environment ##sys#macro-environment1377 #f #t 'reexport)))13781379;;; functor definition13801381(##sys#extend-macro-environment1382 'functor '()1383 (##sys#er-transformer1384 (lambda (x r c)1385 (##sys#check-syntax 'functor x '(_ (_ . #((_ _) 0)) _ . _))1386 (let* ((x (strip-syntax x))1387 (head (cadr x))1388 (name (car head))1389 (args (cdr head))1390 (exps (caddr x))1391 (body (cdddr x))1392 (registration1393 `(##sys#register-functor1394 (##core#quote ,(library-id name))1395 (##core#quote1396 ,(map (lambda (arg)1397 (let ((argname (car arg))1398 (exps (##sys#validate-exports (cadr arg) 'functor)))1399 (unless (or (symbol? argname)1400 (and (list? argname)1401 (= 2 (length argname))1402 (symbol? (car argname))1403 (valid-library-specifier? (cadr argname))))1404 (##sys#syntax-error "invalid functor argument" name arg))1405 (cons argname exps)))1406 args))1407 (##core#quote ,(##sys#validate-exports exps 'functor))1408 (##core#quote ,body))))1409 `(##core#module ,(library-id name)1410 #t1411 (import scheme chicken.syntax) ;; TODO: Is this correct?1412 (begin-for-syntax ,registration))))))14131414;;; interface definition14151416(##sys#extend-macro-environment1417 'define-interface '()1418 (##sys#er-transformer1419 (lambda (x r c)1420 (##sys#check-syntax 'define-interface x '(_ variable _))1421 (let ((name (strip-syntax (cadr x))))1422 (when (eq? '* name)1423 (##sys#syntax-error1424 'define-interface "`*' is not allowed as a name for an interface"))1425 `(##core#elaborationtimeonly1426 (##sys#put/restore!1427 (##core#quote ,name)1428 (##core#quote ##core#interface)1429 (##core#quote1430 ,(let ((exps (strip-syntax (caddr x))))1431 (cond ((eq? '* exps) '*)1432 ((symbol? exps) `(#:interface ,exps))1433 ((list? exps)1434 (##sys#validate-exports exps 'define-interface))1435 (else1436 (##sys#syntax-error1437 'define-interface "invalid exports" (caddr x))))))))))))14381439(##sys#extend-macro-environment1440 'current-module '()1441 (##sys#er-transformer1442 (lambda (x r c)1443 (##sys#check-syntax 'current-module x '(_))1444 (and-let* ((mod (##sys#current-module)))1445 `(##core#quote ,(##sys#module-name mod))))))14461447;; The chicken.module syntax environment1448(define ##sys#chicken.module-macro-environment (##sys#macro-environment))14491450(set! ##sys#scheme-macro-environment1451 (let ((me0 (##sys#macro-environment)))14521453(##sys#extend-macro-environment1454 'lambda1455 '()1456 (##sys#er-transformer1457 (lambda (x r c)1458 (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)))1459 `(##core#lambda ,@(cdr x)))))14601461(##sys#extend-macro-environment1462 'quote1463 '()1464 (##sys#er-transformer1465 (lambda (x r c)1466 (##sys#check-syntax 'quote x '(_ _))1467 `(##core#quote ,(cadr x)))))14681469(##sys#extend-macro-environment1470 'if1471 '()1472 (##sys#er-transformer1473 (lambda (x r c)1474 (##sys#check-syntax 'if x '(_ _ _ . #(_)))1475 `(##core#if ,@(cdr x)))))14761477(##sys#extend-macro-environment1478 'begin1479 '()1480 (##sys#er-transformer1481 (lambda (x r c)1482 (##sys#check-syntax 'begin x '(_ . #(_ 0)))1483 `(##core#begin ,@(cdr x)))))14841485(set! chicken.syntax#define-definition1486 (##sys#extend-macro-environment1487 'define1488 '()1489 (##sys#er-transformer1490 (lambda (x r c)1491 (##sys#check-syntax 'define x '(_ . #(_ 1)))1492 (let loop ((form x))1493 (let ((head (cadr form))1494 (body (cddr form)) )1495 (cond ((not (pair? head))1496 (##sys#check-syntax 'define form '(_ variable . #(_ 0 1)))1497 (let ((name (or (getp head '##core#macro-alias) head)))1498 (##sys#register-export name (##sys#current-module)))1499 (when (c (r 'define) head)1500 (chicken.syntax#defjam-error x))1501 `(##core#begin1502 (##core#ensure-toplevel-definition ,head)1503 (##core#set!1504 ,head1505 ,(if (pair? body) (car body) '(##core#undefined)))))1506 ((pair? (car head))1507 (##sys#check-syntax 'define form '(_ (_ . lambda-list) . #(_ 1)))1508 (loop (chicken.syntax#expand-curried-define head body '()))) ;XXX '() should be se1509 (else1510 (##sys#check-syntax 'define form '(_ (variable . lambda-list) . #(_ 1)))1511 (loop (list (car x) (car head) `(##core#lambda ,(cdr head) ,@body)))))))))))15121513(set! chicken.syntax#define-syntax-definition1514 (##sys#extend-macro-environment1515 'define-syntax1516 '()1517 (##sys#er-transformer1518 (lambda (form r c)1519 (##sys#check-syntax 'define-syntax form '(_ variable _))1520 (let ((head (cadr form))1521 (body (caddr form)))1522 (let ((name (or (getp head '##core#macro-alias) head)))1523 (##sys#register-export name (##sys#current-module)))1524 (when (c (r 'define-syntax) head)1525 (chicken.syntax#defjam-error form))1526 `(##core#define-syntax ,head ,body))))))15271528(##sys#extend-macro-environment1529 'let1530 '()1531 (##sys#er-transformer1532 (lambda (x r c)1533 (cond ((and (pair? (cdr x)) (symbol? (cadr x)))1534 (##sys#check-syntax 'let x '(_ variable #((variable _) 0) . #(_ 1)))1535 (check-for-multiple-bindings (caddr x) x "let"))1536 (else1537 (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)))1538 (check-for-multiple-bindings (cadr x) x "let")))1539 `(##core#let ,@(cdr x)))))15401541(##sys#extend-macro-environment1542 'letrec1543 '()1544 (##sys#er-transformer1545 (lambda (x r c)1546 (##sys#check-syntax 'letrec x '(_ #((variable _) 0) . #(_ 1)))1547 (check-for-multiple-bindings (cadr x) x "letrec")1548 `(##core#letrec ,@(cdr x)))))15491550(##sys#extend-macro-environment1551 'let-syntax1552 '()1553 (##sys#er-transformer1554 (lambda (x r c)1555 (##sys#check-syntax 'let-syntax x '(_ #((variable _) 0) . #(_ 1)))1556 (check-for-multiple-bindings (cadr x) x "let-syntax")1557 `(##core#let-syntax ,@(cdr x)))))15581559(##sys#extend-macro-environment1560 'letrec-syntax1561 '()1562 (##sys#er-transformer1563 (lambda (x r c)1564 (##sys#check-syntax 'letrec-syntax x '(_ #((variable _) 0) . #(_ 1)))1565 (check-for-multiple-bindings (cadr x) x "letrec-syntax")1566 `(##core#letrec-syntax ,@(cdr x)))))15671568(##sys#extend-macro-environment1569 'set!1570 '()1571 (##sys#er-transformer1572 (lambda (x r c)1573 (##sys#check-syntax 'set! x '(_ _ _))1574 (let ((dest (cadr x))1575 (val (caddr x)))1576 (cond ((pair? dest)1577 `((##sys#setter ,(car dest)) ,@(cdr dest) ,val))1578 (else `(##core#set! ,dest ,val)))))))15791580(##sys#extend-macro-environment1581 'and1582 '()1583 (##sys#er-transformer1584 (lambda (form r c)1585 (let ((body (cdr form)))1586 (if (null? body)1587 #t1588 (let ((rbody (cdr body))1589 (hbody (car body)) )1590 (if (null? rbody)1591 hbody1592 `(##core#if ,hbody (,(r 'and) ,@rbody) #f) ) ) ) ) ) ) )15931594(##sys#extend-macro-environment1595 'or1596 '()1597 (##sys#er-transformer1598 (lambda (form r c)1599 (let ((body (cdr form)))1600 (if (null? body)1601 #f1602 (let ((rbody (cdr body))1603 (hbody (car body)))1604 (if (null? rbody)1605 hbody1606 (let ((tmp (r 'tmp)))1607 `(##core#let ((,tmp ,hbody))1608 (##core#if ,tmp ,tmp (,(r 'or) ,@rbody)) ) ) ) ) ) ) ) ) )16091610(##sys#extend-macro-environment1611 'cond1612 '()1613 (##sys#er-transformer1614 (lambda (form r c)1615 (let ((body (cdr form))1616 (%=> (r '=>))1617 (%or (r 'or))1618 (%else (r 'else)))1619 (let expand ((clauses body) (else? #f))1620 (if (not (pair? clauses))1621 '(##core#undefined)1622 (let ((clause (car clauses))1623 (rclauses (cdr clauses)) )1624 (##sys#check-syntax 'cond clause '#(_ 1))1625 (cond (else?1626 (##sys#warn1627 (chicken.format#sprintf "clause following `~S' clause in `cond'" else?)1628 (strip-syntax clause))1629 (expand rclauses else?)1630 '(##core#begin))1631 ((or (c %else (car clause))1632 (eq? #t (car clause))1633 ;; Like "constant?" from support.scm1634 (number? (car clause))1635 (char? (car clause))1636 (string? (car clause))1637 (eof-object? (car clause))1638 (bytevector? (car clause))1639 (bwp-object? (car clause))1640 (vector? (car clause))1641 (##sys#srfi-4-vector? (car clause))1642 (and (pair? (car clause))1643 (c (r 'quote) (caar clause))))1644 (expand rclauses (strip-syntax (car clause)))1645 (cond ((and (fx= (length clause) 3)1646 (c %=> (cadr clause)))1647 `(,(caddr clause) ,(car clause)))1648 ((pair? (cdr clause))1649 `(##core#begin ,@(cdr clause)))1650 ((c %else (car clause))1651 `(##core#undefined))1652 (else (car clause))))1653 ((null? (cdr clause))1654 `(,%or ,(car clause) ,(expand rclauses #f)))1655 ((and (fx= (length clause) 3)1656 (c %=> (cadr clause)))1657 (let ((tmp (r 'tmp)))1658 `(##core#let ((,tmp ,(car clause)))1659 (##core#if ,tmp1660 (,(caddr clause) ,tmp)1661 ,(expand rclauses #f) ) ) ) )1662 ((and (fx= (length clause) 4)1663 (c %=> (caddr clause)))1664 (let ((tmp (r 'tmp)))1665 `(##sys#call-with-values1666 (##core#lambda () ,(car clause))1667 (##core#lambda1668 ,tmp1669 (if (##sys#apply ,(cadr clause) ,tmp)1670 (##sys#apply ,(cadddr clause) ,tmp)1671 ,(expand rclauses #f) ) ) ) ) )1672 (else `(##core#if ,(car clause)1673 (##core#begin ,@(cdr clause))1674 ,(expand rclauses #f) ) ) ) ) ) ) ) ) ) )16751676(##sys#extend-macro-environment1677 'case1678 '((eqv? . scheme#eqv?))1679 (##sys#er-transformer1680 (lambda (form r c)1681 (##sys#check-syntax 'case form '(_ _ . #(_ 0)))1682 (let ((exp (cadr form))1683 (body (cddr form)) )1684 (let ((tmp (r 'tmp))1685 (%or (r 'or))1686 (%=> (r '=>))1687 (%eqv? (r 'eqv?))1688 (%else (r 'else)))1689 `(let ((,tmp ,exp))1690 ,(let expand ((clauses body) (else? #f))1691 (if (not (pair? clauses))1692 '(##core#undefined)1693 (let ((clause (car clauses))1694 (rclauses (cdr clauses)) )1695 (##sys#check-syntax 'case clause '#(_ 1))1696 (cond (else?1697 (##sys#warn1698 "clause following `else' clause in `case'"1699 (strip-syntax clause))1700 (expand rclauses #t)1701 '(##core#begin))1702 ((c %else (car clause))1703 (expand rclauses #t)1704 (cond ((null? (cdr clause))1705 `(##core#undefined))1706 ((and (fx= (length clause) 3) ; (else => expr)1707 (c %=> (cadr clause)))1708 `(,(caddr clause) ,tmp))1709 (else1710 `(##core#begin ,@(cdr clause)))))1711 (else1712 `(##core#if (,%or ,@(##sys#map1713 (lambda (x) `(,%eqv? ,tmp ',x))1714 (car clause)))1715 ,(if (and (fx= (length clause) 3) ; ((...) => expr)1716 (c %=> (cadr clause)))1717 `(,(caddr clause) ,tmp)1718 `(##core#begin ,@(cdr clause)))1719 ,(expand rclauses #f) ) ) ) ) ) ) ) ) ) ) ) )17201721(##sys#extend-macro-environment1722 'let*1723 '()1724 (##sys#er-transformer1725 (lambda (form r c)1726 (##sys#check-syntax 'let* form '(_ #((variable _) 0) . #(_ 1)))1727 (let ((bindings (cadr form))1728 (body (cddr form)) )1729 (let expand ((bs bindings))1730 (if (eq? bs '())1731 `(##core#let () ,@body)1732 `(##core#let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) ) )17331734(##sys#extend-macro-environment1735 'do1736 '()1737 (##sys#er-transformer1738 (lambda (form r c)1739 (##sys#check-syntax 'do form '(_ #((variable _ . #(_)) 0) . #(_ 1)))1740 (let ((bindings (cadr form))1741 (test (caddr form))1742 (body (cdddr form))1743 (dovar (r 'doloop)))1744 `(##core#let1745 ,dovar1746 ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)1747 (##core#if ,(car test)1748 ,(let ((tbody (cdr test)))1749 (if (eq? tbody '())1750 '(##core#undefined)1751 `(##core#begin ,@tbody) ) )1752 (##core#begin1753 ,(if (eq? body '())1754 '(##core#undefined)1755 `(##core#let () ,@body) )1756 (##core#app1757 ,dovar ,@(##sys#map (lambda (b)1758 (if (eq? (cdr (cdr b)) '())1759 (car b)1760 (car (cdr (cdr b))) ) )1761 bindings) ) ) ) ) ) ) ) )17621763(##sys#extend-macro-environment1764 'quasiquote1765 '()1766 (##sys#er-transformer1767 (lambda (form r c)1768 (let ((%quasiquote (r 'quasiquote))1769 (%unquote (r 'unquote))1770 (%unquote-splicing (r 'unquote-splicing)))1771 (define (walk x n) (simplify (walk1 x n)))1772 (define (walk1 x n)1773 (cond ((vector? x)1774 `(##sys#list->vector ,(walk (vector->list x) n)) )1775 ((not (pair? x)) `(##core#quote ,x))1776 (else1777 (let ((head (car x))1778 (tail (cdr x)))1779 (cond ((c %unquote head)1780 (cond ((eq? n 0)1781 (##sys#check-syntax 'unquote x '(_ _))1782 (car tail))1783 (else (list '##sys#cons `(##core#quote ,%unquote)1784 (walk tail (fx- n 1)) ) )))1785 ((c %quasiquote head)1786 (list '##sys#cons `(##core#quote ,%quasiquote)1787 (walk tail (fx+ n 1)) ) )1788 ((and (pair? head) (c %unquote-splicing (car head)))1789 (cond ((eq? n 0)1790 (##sys#check-syntax 'unquote-splicing head '(_ _))1791 `(##sys#append ,(cadr head) ,(walk tail n)))1792 (else1793 `(##sys#cons1794 (##sys#cons (##core#quote ,%unquote-splicing)1795 ,(walk (cdr head) (fx- n 1)) )1796 ,(walk tail n)))))1797 (else1798 `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )1799 (define (simplify x)1800 (cond ((chicken.syntax#match-expression x '(##sys#cons a (##core#quote ())) '(a))1801 => (lambda (env) (simplify `(##sys#list ,(cdr (assq 'a env))))) )1802 ((chicken.syntax#match-expression x '(##sys#cons a (##sys#list . b)) '(a b))1803 => (lambda (env)1804 (let ((bxs (assq 'b env)))1805 (if (fx< (length bxs) 32)1806 (simplify `(##sys#list ,(cdr (assq 'a env))1807 ,@(cdr bxs) ) )1808 x) ) ) )1809 ((chicken.syntax#match-expression x '(##sys#append a (##core#quote ())) '(a))1810 => (lambda (env) (cdr (assq 'a env))) )1811 (else x) ) )1812 (##sys#check-syntax 'quasiquote form '(_ _))1813 (walk (cadr form) 0) ) ) ) )18141815(##sys#extend-macro-environment1816 'delay1817 '()1818 (##sys#er-transformer1819 (lambda (form r c)1820 (##sys#check-syntax 'delay form '(_ _))1821 `(,(r 'delay-force)1822 (##sys#make-promise1823 (##sys#call-with-values (##core#lambda () ,(cadr form)) ##sys#list))))))18241825(##sys#extend-macro-environment1826 'syntax-error1827 '()1828 (##sys#er-transformer1829 (lambda (form r c)1830 (##sys#check-syntax 'syntax-error form '(_ string . #(_ 0)))1831 (apply ##sys#syntax-error (cadr form) (cddr form)))))18321833;;; syntax-rules18341835(include "synrules.scm")18361837(macro-subset me0)))18381839;;; the base macro environment (the old "scheme", essentially)1840;;; TODO: Remove this18411842(define ##sys#default-macro-environment1843 (fixup-macro-environment (##sys#macro-environment)))18441845(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))18461847;; register features18481849(register-feature! 'srfi-0 'srfi-46 'srfi-61 'srfi-87)