~ 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 expand140 get-line-number41 read-with-source-info42 strip-syntax43 er-macro-transformer44 ir-macro-transformer)4546(import scheme47 chicken.base48 chicken.condition49 chicken.fixnum50 chicken.internal51 chicken.keyword52 chicken.platform53 chicken.string)54(import (only (scheme base) make-parameter open-output-string get-output-string))5556(include "common-declarations.scm")57(include "mini-srfi-1.scm")5859(define-syntax d (syntax-rules () ((_ . _) (void))))60;(define-syntax d (syntax-rules () ((_ args ...) (print args ...))))6162;; Macro to avoid "unused variable map-se" when "d" is disabled63(define-syntax map-se64 (syntax-rules ()65 ((_ ?se)66 (map (lambda (a)67 (cons (car a) (if (symbol? (cdr a)) (cdr a) '<macro>)))68 ?se))))6970(define-alias dd d)71(define-alias dm d)72(define-alias dx d)7374(define-inline (getp sym prop)75 (##core#inline "C_i_getprop" sym prop #f))7677(define-inline (putp sym prop val)78 (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val))7980(define-inline (namespaced-symbol? sym)81 (##core#inline "C_u_i_namespaced_symbolp" sym))8283;;; Source file tracking8485(define ##sys#current-source-filename #f)8687;;; Syntactic environments8889(define ##sys#current-environment (make-parameter '()))90(define ##sys#current-meta-environment (make-parameter '()))9192(define (lookup id se)93 (cond ((##core#inline "C_u_i_assq" id se) => cdr)94 ((getp id '##core#macro-alias))95 (else #f)))9697(define (macro-alias var se)98 (if (or (keyword? var) (namespaced-symbol? var))99 var100 (let* ((alias (gensym var))101 (ua (or (lookup var se) var))102 (rn (or (getp var '##core#real-name) var)))103 (putp alias '##core#macro-alias ua)104 (putp alias '##core#real-name rn)105 (dd "aliasing " alias " (real: " var ") to "106 (if (pair? ua)107 '<macro>108 ua))109 alias) ) )110111(define (strip-syntax exp)112 (let ((seen '()))113 (let walk ((x exp))114 (cond ((assq x seen) => cdr)115 ((keyword? x) x)116 ((symbol? x)117 (let ((x2 (getp x '##core#macro-alias) ) )118 (cond ((getp x '##core#real-name))119 ((not x2) x)120 ((pair? x2) x)121 (else x2))))122 ((pair? x)123 (let ((cell (cons #f #f)))124 (set! seen (cons (cons x cell) seen))125 (set-car! cell (walk (car x)))126 (set-cdr! cell (walk (cdr x)))127 cell))128 ((vector? x)129 (let* ((len (##sys#size x))130 (vec (make-vector len)))131 (set! seen (cons (cons x vec) seen))132 (do ((i 0 (fx+ i 1)))133 ((fx>= i len) vec)134 (##sys#setslot vec i (walk (##sys#slot x i))))))135 (else x)))))136137(define (##sys#extend-se se vars #!optional (aliases (map gensym vars)))138 (for-each139 (lambda (alias sym)140 (let ((original-real-name (getp sym '##core#real-name)))141 (putp alias '##core#real-name (or original-real-name sym))))142 aliases vars)143 (append (map (lambda (x y) (cons x y)) vars aliases) se)) ; inline cons144145146;;; Macro handling147148(define ##sys#macro-environment (make-parameter '()))149150(define ##sys#scheme-macro-environment '()) ; reassigned below151;; These are all re-assigned by chicken-syntax.scm:152(define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm153(define ##sys#chicken.condition-macro-environment '()) ; used later in chicken.condition.import.scm154(define ##sys#chicken.time-macro-environment '()) ; used later in chicken.time.import.scm155(define ##sys#chicken.type-macro-environment '()) ; used later in chicken.type.import.scm156(define ##sys#chicken.syntax-macro-environment '()) ; used later in chicken.syntax.import.scm157(define ##sys#chicken.base-macro-environment '()) ; used later in chicken.base.import.scm158159(define (##sys#ensure-transformer t #!optional loc)160 (if (##sys#structure? t 'transformer)161 (##sys#slot t 1)162 (##sys#error loc "expected syntax-transformer, but got" t)))163164(define (##sys#extend-macro-environment name se transformer)165 (let ((me (##sys#macro-environment))166 (handler (##sys#ensure-transformer transformer name)))167 (cond ((lookup name me) =>168 (lambda (a)169 (set-car! a se)170 (set-car! (cdr a) handler)171 a))172 (else173 (let ((data (list se handler)))174 (##sys#macro-environment175 (cons (cons name data) me))176 data)))))177178(define (##sys#macro? sym #!optional (senv (##sys#current-environment)))179 (or (let ((l (lookup sym senv)))180 (pair? l))181 (and-let* ((l (lookup sym (##sys#macro-environment))))182 (pair? l))))183184(define (##sys#undefine-macro! name)185 (##sys#macro-environment186 ;; this builds up stack, but isn't used often anyway...187 (let loop ((me (##sys#macro-environment)))188 (cond ((null? me) '())189 ((eq? name (caar me)) (cdr me))190 (else (cons (car me) (loop (cdr me))))))))191192;; The basic macro-expander193194(define (##sys#expand-0 exp dse cs?)195 (define (call-handler name handler exp se cs)196 (dd "invoking macro: " name)197 (dd `(STATIC-SE: ,@(map-se se)))198 (handle-exceptions ex199 ;; modify error message in condition object to include200 ;; currently expanded macro-name201 (abort202 (if (and (##sys#structure? ex 'condition)203 (memv 'exn (##sys#slot ex 1)) )204 (##sys#make-structure205 'condition206 (##sys#slot ex 1)207 (let copy ([ps (##sys#slot ex 2)])208 (if (null? ps)209 '()210 (let ([p (car ps)]211 [r (cdr ps)])212 (if (and (equal? '(exn . message) p)213 (pair? r)214 (string? (car r)) )215 (cons216 '(exn . message)217 (cons (string-append218 "during expansion of ("219 (##sys#symbol->string/shared name)220 " ...) - "221 (car r) )222 (cdr r) ) )223 (copy r) ) ) ) ) )224 ex) )225 (let ((exp2226 (if cs227 ;; compiler-syntax may "fall through"228 (fluid-let ((chicken.internal.syntax-rules#syntax-rules-mismatch229 (lambda (input) exp))) ; a bit of a hack230 (handler exp se dse))231 (handler exp se dse))) )232 (when (and (not cs) (eq? exp exp2))233 (##sys#syntax-error234 (string-append235 "syntax transformer for `" (##sys#symbol->string/shared name)236 "' returns original form, which would result in endless expansion")237 exp))238 (dx `(,name ~~> ,exp2))239 (expansion-result-hook exp exp2) ) ) )240 (define (expand head exp mdef)241 (dd `(EXPAND:242 ,head243 ,(cond ((getp head '##core#macro-alias) =>244 (lambda (a) (if (symbol? a) a '<macro>)) )245 (else '_))246 ,exp247 ,(if (pair? mdef)248 `(SE: ,@(map-se (car mdef)))249 mdef)))250 (if (pair? mdef)251 (values252 ;; force ref. opaqueness by passing dynamic se [what does this comment mean? I forgot ...]253 (call-handler head (cadr mdef) exp (car mdef) #f)254 #t)255 (values exp #f)) )256 (let loop ((exp exp))257 (if (pair? exp)258 (let ((head (car exp))259 (body (cdr exp)) )260 (if (symbol? head)261 (let ((head2 (or (lookup head dse) head)))262 (unless (pair? head2)263 (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )264 (cond ((and (pair? head2)265 (eq? (##sys#get head '##sys#override) 'value))266 (values exp #f))267 ((eq? head2 '##core#let)268 (##sys#check-syntax 'let body '#(_ 2) #f dse)269 (let ((bindings (car body)))270 (cond ((symbol? bindings) ; expand named let271 (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)272 (let ([bs (cadr body)])273 (values274 `(##core#app275 (##core#letrec*276 ([,bindings277 (##core#loop-lambda278 ,(map (lambda (b) (car b)) bs) ,@(cddr body))])279 ,bindings)280 ,@(##sys#map cadr bs) )281 #t) ) )282 (else (values exp #f)) ) ) )283 ((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) =>284 (lambda (cs)285 (let ((result (call-handler head (car cs) exp (cdr cs) #t)))286 (cond ((eq? result exp) (expand head exp head2))287 (else288 (when ##sys#compiler-syntax-hook289 (##sys#compiler-syntax-hook head2 result))290 (loop result))))))291 (else (expand head exp head2)) ) )292 (values exp #f) ) )293 (values exp #f) ) ) )294295(define ##sys#compiler-syntax-hook #f)296(define ##sys#enable-runtime-macros #f)297(define expansion-result-hook (lambda (input output) output))298299300;;; User-level macroexpansion301302(define (expand exp #!optional (se (##sys#current-environment)) cs?)303 (let loop ((exp exp))304 (let-values (((exp2 m) (##sys#expand-0 exp se cs?)))305 (if m306 (loop exp2)307 exp2) ) ) )308309(define (expand1 exp #!optional (se (##sys#current-environment)) cs?)310 (nth-value 0 (##sys#expand-0 exp se cs?)) )311312313;;; Extended (DSSSL-style) lambda lists314;315; Assumptions:316;317; 1) #!rest must come before #!key318; 2) default values may refer to earlier variables319; 3) optional/key args may be either variable or (variable default)320; 4) an argument marker may not be specified more than once321; 5) no special handling of extra keywords (no error)322; 6) default value of optional/key args is #f323; 7) mixing with dotted list syntax is allowed324325(define (##sys#extended-lambda-list? llist)326 (let loop ([llist llist])327 (and (pair? llist)328 (case (##sys#slot llist 0)329 [(#!rest #!optional #!key) #t]330 [else (loop (cdr llist))] ) ) ) )331332(define ##sys#expand-extended-lambda-list333 (let ((reverse reverse))334 (lambda (llist0 body errh se)335 (define (err msg) (errh msg llist0))336 (define (->keyword s) (string->keyword (##sys#symbol->string/shared s)))337 (let ((rvar #f)338 (hasrest #f)339 ;; These might not exist in se, use default or chicken env:340 (%let* (macro-alias 'let* ##sys#default-macro-environment))341 (%lambda '##core#lambda)342 (%opt (macro-alias 'optional ##sys#chicken.base-macro-environment))343 (%let-optionals* (macro-alias 'let-optionals* ##sys#chicken.base-macro-environment))344 (%let '##core#let))345 (let loop ([mode 0] ; req=0, opt=1, rest=2, key=3, end=4346 [req '()]347 [opt '()]348 [key '()]349 [llist llist0] )350 (cond [(null? llist)351 (values352 (if rvar (##sys#append (reverse req) rvar) (reverse req))353 (let ([body354 (if (null? key)355 body356 `((,%let*357 ,(map (lambda (k)358 (let ((s (car k)))359 `(,s (##sys#get-keyword360 (##core#quote ,(->keyword (strip-syntax s))) ,(or hasrest rvar)361 ,@(if (pair? (cdr k))362 `((,%lambda () ,@(cdr k)))363 '())))))364 (reverse key) )365 ,@body) ) ) ] )366 (cond [(null? opt) body]367 [(and (not hasrest) (null? key) (null? (cdr opt)))368 `((,%let369 ([,(caar opt) (,%opt ,rvar ,(cadar opt))])370 ,@body) ) ]371 [(and (not hasrest) (null? key))372 `((,%let-optionals*373 ,rvar ,(reverse opt) ,@body))]374 [else375 `((,%let-optionals*376 ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar)))377 ,@body))] ) ) ) ]378 [(symbol? llist)379 (if (fx> mode 2)380 (err "rest argument list specified more than once")381 (begin382 (unless rvar (set! rvar llist))383 (set! hasrest llist)384 (loop 4 req opt '() '()) ) ) ]385 [(not (pair? llist))386 (err "invalid lambda list syntax") ]387 [else388 (let* ((var (car llist))389 (x (or (and (symbol? var) (not (eq? 3 mode)) (lookup var se)) var))390 (r (cdr llist)))391 (case x392 [(#!optional)393 (unless rvar (set! rvar (macro-alias 'rest se)))394 (if (eq? mode 0)395 (loop 1 req '() '() r)396 (err "`#!optional' argument marker in wrong context") ) ]397 [(#!rest)398 (if (fx<= mode 1)399 (if (and (pair? r) (symbol? (car r)))400 (begin401 (if (not rvar) (set! rvar (car r)))402 (set! hasrest (car r))403 (loop 2 req opt '() (cdr r)) )404 (err "invalid syntax of `#!rest' argument") )405 (err "`#!rest' argument marker in wrong context") ) ]406 [(#!key)407 (if (not rvar) (set! rvar (macro-alias 'rest se)))408 (if (fx<= mode 2)409 (loop 3 req opt '() r)410 (err "`#!key' argument marker in wrong context") ) ]411 [else412 (cond [(symbol? var)413 (case mode414 [(0) (loop 0 (cons var req) '() '() r)]415 [(1) (loop 1 req (cons (list var #f) opt) '() r)]416 [(2) (err "invalid lambda list syntax after `#!rest' marker")]417 [else (loop 3 req opt (cons (list var) key) r)] ) ]418 [(and (list? var) (eq? 2 (length var)) (symbol? (car var)))419 (case mode420 [(0) (err "invalid required argument syntax")]421 [(1) (loop 1 req (cons var opt) '() r)]422 [(2) (err "invalid lambda list syntax after `#!rest' marker")]423 [else (loop 3 req opt (cons var key) r)] ) ]424 [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )425426427;;; Error message for redefinition of currently used defining form428;429; (i.e.`"(define define ...)")430431(define (defjam-error form)432 (##sys#syntax-error433 "redefinition of currently used defining form" ; help me find something better434 form))435436;;; Expansion of multiple values assignments.437;438; Given a lambda list and a multi-valued expression, returns a form that439; will `set!` each variable to its corresponding value in order.440441(define (##sys#expand-multiple-values-assignment formals expr)442 (##sys#decompose-lambda-list443 formals444 (lambda (vars argc rest)445 (let ((aliases (if (symbol? formals) '() (map gensym formals)))446 (rest-alias (if (not rest) '() (gensym rest))))447 `(##sys#call-with-values448 (##core#lambda () ,expr)449 (##core#lambda450 ,(append aliases rest-alias)451 ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases)452 ,@(cond453 ((null? formals) '((##core#undefined)))454 ((null? rest-alias) '())455 (else `((##core#set! ,rest ,rest-alias))))))))))456457;;; Expansion of bodies (and internal definitions)458;459; This code is disgustingly complex.460461(define define-definition)462(define define-syntax-definition)463(define define-values-definition)464(define import-definition)465466(define ##sys#canonicalize-body467 (lambda (body #!optional (se (##sys#current-environment)) cs?)468 (define (comp s id)469 (let ((f (or (lookup id se)470 (lookup id (##sys#macro-environment)))))471 (and (or (not (symbol? f))472 (not (eq? (##sys#get id '##sys#override) 'value)))473 (or (eq? f s) (eq? s id)))))474 (define (comp-def def)475 (lambda (id)476 (let repeat ((id id))477 (let ((f (or (lookup id se)478 (lookup id (##sys#macro-environment)))))479 (and (or (not (symbol? f))480 (not (eq? (##sys#get id '##sys#override) 'value)))481 (or (eq? f def)482 (and (symbol? f)483 (not (eq? f id))484 (repeat f))))))))485 (define comp-define (comp-def define-definition))486 (define comp-define-syntax (comp-def define-syntax-definition))487 (define comp-define-values (comp-def define-values-definition))488 (define comp-import (comp-def import-definition))489 (define (fini vars vals mvars body)490 (if (and (null? vars) (null? mvars))491 ;; Macro-expand body, and restart when defines are found.492 (let loop ((body body) (exps '()))493 (if (not (pair? body))494 (cons495 '##core#begin496 (reverse exps)) ; no more defines, otherwise we would have called `expand'497 (let loop2 ((body body))498 (let ((x (car body))499 (rest (cdr body)))500 (if (and (pair? x)501 (let ((d (car x)))502 (and (symbol? d)503 (or (comp '##core#begin d)504 (comp-define d)505 (comp-define-values d)506 (comp-define-syntax d)507 (comp-import d)))))508 ;; Stupid hack to avoid expanding imports509 (if (comp-import (car x))510 (loop rest (cons x exps))511 (cons512 '##core#begin513 (##sys#append (reverse exps) (list (expand body)))))514 (let ((x2 (##sys#expand-0 x se cs?)))515 (if (eq? x x2)516 ;; Modules and includes must be processed before517 ;; we can continue with other forms, so hand518 ;; control back to the compiler519 (if (and (pair? x)520 (symbol? (car x))521 (or (comp '##core#module (car x))522 (comp '##core#include (car x))))523 `(##core#begin524 ,@(reverse exps)525 ,@(if (comp '##core#module (car x))526 (if (null? rest)527 `(,x)528 `(,x (##core#let () ,@rest)))529 `((##core#include ,@(cdr x) ,rest))))530 (loop rest (cons x exps)))531 (loop2 (cons x2 rest)) )) ))) ))532 ;; We saw defines. Translate to letrec, and let compiler533 ;; call us again for the remaining body by wrapping the534 ;; remaining body forms in a ##core#let.535 (let* ((result536 `(##core#let537 ,(##sys#map538 (lambda (v) (##sys#list v '(##core#undefined)))539 ;; vars are all normalised to lambda-lists: flatten them540 (foldl (lambda (l v)541 (##sys#append l (##sys#decompose-lambda-list542 v (lambda (a _ _) a))))543 '()544 (reverse vars))) ; not strictly necessary...545 ,@(map (lambda (var val is-mvar?)546 ;; Non-mvars should expand to set! for547 ;; efficiency, but also because they must be548 ;; implicit multi-value continuations.549 (if is-mvar?550 (##sys#expand-multiple-values-assignment var val)551 `(##core#set! ,(car var) ,val)))552 (reverse vars)553 (reverse vals)554 (reverse mvars))555 ,@body) ) )556 (dd `(BODY: ,result))557 result)))558 (define (fini/syntax vars vals mvars body)559 (fini560 vars vals mvars561 (let loop ((body body) (defs '()) (done #f))562 (cond (done `((##core#letrec-syntax563 ,(map cdr (reverse defs)) ,@body) ))564 ((not (pair? body)) (loop body defs #t))565 ((and (list? (car body))566 (>= 3 (length (car body)))567 (symbol? (caar body))568 (comp-define-syntax (caar body)))569 (let ((def (car body)))570 ;; This check is insufficient, if introduced by571 ;; different expansions, but better than nothing:572 (when (eq? (car def) (cadr def))573 (defjam-error def))574 (loop (cdr body) (cons def defs) #f)))575 (else (loop body defs #t))))))576 ;; Expand a run of defines or define-syntaxes into letrec. As577 ;; soon as we encounter something else, finish up.578 (define (expand body)579 ;; Each #t in "mvars" indicates an MV-capable "var". Non-MV580 ;; vars (#f in mvars) are 1-element lambda-lists for simplicity.581 (let loop ((body body) (vars '()) (vals '()) (mvars '()))582 (d "BODY: " body)583 (if (not (pair? body))584 (fini vars vals mvars body)585 (let* ((x (car body))586 (rest (cdr body))587 (exp1 (and (pair? x) (car x)))588 (head (and exp1 (symbol? exp1) exp1)))589 (if (not (symbol? head))590 (fini vars vals mvars body)591 (cond592 ((comp-define head)593 (##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)594 (let loop2 ((x x))595 (let ((head (cadr x)))596 (cond ((not (pair? head))597 (##sys#check-syntax 'define x '(_ variable . #(_ 0)) #f se)598 (when (eq? (car x) head) ; see above599 (defjam-error x))600 (loop rest (cons (list head) vars)601 (cons (if (pair? (cddr x))602 (caddr x)603 '(##core#undefined) )604 vals)605 (cons #f mvars)))606 ((pair? (car head))607 (##sys#check-syntax608 'define x '(_ (_ . lambda-list) . #(_ 1)) #f se)609 (loop2610 (chicken.syntax#expand-curried-define head (cddr x) se)))611 (else612 (##sys#check-syntax613 'define x614 '(_ (variable . lambda-list) . #(_ 1)) #f se)615 (loop rest616 (cons (list (car head)) vars)617 (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)618 (cons #f mvars)))))))619 ((comp-define-syntax head)620 (##sys#check-syntax 'define-syntax x '(_ _ . #(_ 1)) se)621 (fini/syntax vars vals mvars body))622 ((comp-define-values head)623 ;;XXX check for any of the variables being `define-values'624 (##sys#check-syntax 'define-values x '(_ lambda-list _) #f se)625 (loop rest (cons (cadr x) vars) (cons (caddr x) vals) (cons #t mvars)))626 ((comp '##core#begin head)627 (loop (##sys#append (cdr x) rest) vars vals mvars))628 (else629 ;; Do not macro-expand local definitions we are630 ;; in the process of introducing.631 (if (member (list head) vars)632 (fini vars vals mvars body)633 (let ((x2 (##sys#expand-0 x se cs?)))634 (if (eq? x x2)635 (fini vars vals mvars body)636 (loop (cons x2 rest) vars vals mvars)))))))))))637 (expand body) ) )638639640;;; A simple expression matcher641642;; Used by "quasiquote", below643(define chicken.syntax#match-expression644 (lambda (exp pat vars)645 (let ((env '()))646 (define (mwalk x p)647 (cond ((not (pair? p))648 (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))649 ((memq p vars)650 (set! env (cons (cons p x) env))651 #t)652 (else (eq? x p)) ) )653 ((pair? x)654 (and (mwalk (car x) (car p))655 (mwalk (cdr x) (cdr p)) ) )656 (else #f) ) )657 (and (mwalk exp pat) env) ) ) )658659660;;; Expand "curried" lambda-list syntax for `define'661662;; Used by "define", below663(define (chicken.syntax#expand-curried-define head body se)664 (let ((name #f))665 (define (loop head body)666 (if (symbol? (car head))667 (begin668 (set! name (car head))669 `(##core#lambda ,(cdr head) ,@body) )670 (loop (car head) `((##core#lambda ,(cdr head) ,@body)) ) ))671 (let ([exp (loop head body)])672 (list 'define name exp) ) ) )673674675;;; Line-number database management:676677(define ##sys#line-number-database #f)678679680;;; General syntax checking routine:681682(define ##sys#syntax-error-culprit #f)683(define ##sys#syntax-context '())684685(define (##sys#syntax-error-hook . args)686 (apply ##sys#signal-hook #:syntax-error687 (strip-syntax args)))688689(define (##sys#syntax-error . args)690 (apply ##sys#syntax-error-hook args))691692(define ##sys#syntax-error/context693 (lambda (msg arg)694 (define (syntax-imports sym)695 (let loop ((defs (or (##sys#get (strip-syntax sym) '##core#db) '())))696 (cond ((null? defs) '())697 ((eq? 'syntax (caar defs))698 (cons (cadar defs) (loop (cdr defs))))699 (else (loop (cdr defs))))))700 (if (null? ##sys#syntax-context)701 (##sys#syntax-error-hook msg arg)702 (let ((out (open-output-string)))703 (define (outstr str)704 (##sys#print str #f out))705 (let loop ((cx ##sys#syntax-context))706 (cond ((null? cx) ; no unimported syntax found707 (outstr msg)708 (outstr ": ")709 (##sys#print arg #t out)710 (outstr "\ninside expression `(")711 (##sys#print (strip-syntax (car ##sys#syntax-context)) #t out)712 (outstr " ...)'"))713 (else714 (let* ((sym (strip-syntax (car cx)))715 (us (syntax-imports sym)))716 (cond ((pair? us)717 (outstr msg)718 (outstr ": ")719 (##sys#print arg #t out)720 (outstr "\n\n Perhaps you intended to use the syntax `(")721 (##sys#print sym #t out)722 (outstr " ...)' without importing it first.\n")723 (if (fx= 1 (length us))724 (outstr725 (string-append726 " Suggesting: `(import "727 (symbol->string (car us))728 ")'"))729 (outstr730 (string-append731 " Suggesting one of:\n"732 (let loop ((lst us))733 (if (null? lst)734 ""735 (string-append736 "\n (import " (symbol->string (car lst)) ")'"737 (loop (cdr lst)))))))))738 (else (loop (cdr cx))))))))739 (##sys#syntax-error-hook (get-output-string out))))))740741;;; Hook for source information742743(define (alist-weak-cons k v lst)744 (cons (##core#inline_allocate ("C_a_i_weak_cons" 3) k v) lst))745746(define (assq/drop-bwp! x lst)747 (let lp ((lst lst)748 (prev #f))749 (cond ((null? lst) #f)750 ((eq? x (caar lst)) (car lst))751 ((and prev752 (##core#inline "C_bwpp" (caar lst)))753 (set-cdr! prev (cdr lst))754 (lp (cdr lst) prev))755 (else (lp (cdr lst) lst)))))756757(define (read-with-source-info-hook class data val)758 (when (and (eq? 'list-info class) (symbol? (car data)))759 (let ((old-value (or (hash-table-ref ##sys#line-number-database (car data)) '())))760 (assq/drop-bwp! (car data) old-value) ;; Hack to clean out garbage values761 (hash-table-set!762 ##sys#line-number-database763 (car data)764 (alist-weak-cons765 data (conc (or ##sys#current-source-filename "<stdin>") ":" val)766 old-value ) )) )767 data)768769(define-constant line-number-database-size 997) ; Copied from core.scm770771(define (read-with-source-info #!optional (in ##sys#standard-input))772 ;; Initialize line number db on first use773 (unless ##sys#line-number-database774 (set! ##sys#line-number-database (make-vector line-number-database-size '())))775 (##sys#check-input-port in #t 'read-with-source-info)776 (##sys#read in read-with-source-info-hook) )777778779(define (get-line-number sexp)780 (and ##sys#line-number-database781 (pair? sexp)782 (let ([head (car sexp)])783 (and (symbol? head)784 (cond ((hash-table-ref ##sys#line-number-database head)785 => (lambda (pl)786 (let ((a (assq/drop-bwp! sexp pl)))787 (and a (cdr a)))))788 (else #f))))))789790;; TODO: Needs a better name - it extracts the name(?) and the source expression791(define (##sys#get-line-2 exp)792 (let* ((name (car exp))793 (lst (hash-table-ref ##sys#line-number-database name)))794 (cond ((and lst (assq/drop-bwp! exp (cdr lst)))795 => (lambda (a) (values (car lst) (cdr a))) )796 (else (values name #f)) ) ) )797798(define (##sys#display-line-number-database)799 (hash-table-for-each800 (lambda (key val)801 (when val802 (let ((port (current-output-port)))803 (##sys#print key #t port)804 (##sys#print " " #f port)805 (##sys#print (map cdr val) #t port)806 (##sys#print "\n" #f port))) )807 ##sys#line-number-database) )808809;;; Traverse expression and update line-number db with all contained calls:810811(define (##sys#update-line-number-database! exp ln)812 (define (mapupdate xs)813 (let loop ((xs xs))814 (when (pair? xs)815 (walk (car xs))816 (loop (cdr xs)) ) ))817 (define (walk x)818 (cond ((not (pair? x)))819 ((symbol? (car x))820 (let* ((name (car x))821 (old (or (hash-table-ref ##sys#line-number-database name) '())))822 (unless (assq x old)823 (hash-table-set! ##sys#line-number-database name (alist-cons x ln old)))824 (when (list? x) (mapupdate (cdr x)) )))825 (else (mapupdate x)) ) )826 (walk exp))827828829(define-constant +default-argument-count-limit+ 99999)830831(define ##sys#check-syntax832 (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))833834 (define (test x pred msg)835 (unless (pred x) (err msg)) )836837 (define (err msg)838 (let* ([sexp ##sys#syntax-error-culprit]839 [ln (get-line-number sexp)] )840 (##sys#syntax-error841 (if ln842 (string-append "(" ln ") in `" (symbol->string id) "' - " msg)843 (string-append "in `" (symbol->string id) "' - " msg) )844 exp) ) )845846 (define (lambda-list? x)847 (or (##sys#extended-lambda-list? x)848 (let loop ((x x))849 (cond ((null? x))850 ((symbol? x))851 ((pair? x)852 (let ((s (car x)))853 (and (symbol? s)854 (loop (cdr x)) ) ) )855 (else #f) ) ) ) )856857 (define (variable? v)858 (symbol? v))859860 (define (proper-list? x)861 (let loop ((x x))862 (cond ((eq? x '()))863 ((pair? x) (loop (cdr x)))864 (else #f) ) ) )865866 (when culprit (set! ##sys#syntax-error-culprit culprit))867 (let walk ((x exp) (p pat))868 (cond ((vector? p)869 (let* ((p2 (vector-ref p 0))870 (vlen (##sys#size p))871 (min (if (fx> vlen 1)872 (vector-ref p 1)873 0) )874 (max (cond ((eq? vlen 1) 1)875 ((fx> vlen 2) (vector-ref p 2))876 (else +default-argument-count-limit+) ) ) )877 (do ((x x (cdr x))878 (n 0 (fx+ n 1)) )879 ((eq? x '())880 (if (fx< n min)881 (err "not enough arguments") ) )882 (cond ((fx>= n max)883 (err "too many arguments") )884 ((not (pair? x))885 (err "not a proper list") )886 (else (walk (car x) p2) ) ) ) ) )887 ((##sys#immediate? p)888 (if (not (eq? p x)) (err "unexpected object")) )889 ((symbol? p)890 (case p891 ((_) #t)892 ((pair) (test x pair? "pair expected"))893 ((variable) (test x variable? "identifier expected"))894 ((symbol) (test x symbol? "symbol expected"))895 ((list) (test x proper-list? "proper list expected"))896 ((number) (test x number? "number expected"))897 ((string) (test x string? "string expected"))898 ((lambda-list) (test x lambda-list? "lambda-list expected"))899 (else900 (test901 x902 (lambda (y)903 (let ((y2 (and (symbol? y) (lookup y se))))904 (eq? (if (symbol? y2) y2 y) p)))905 "missing keyword")) ) )906 ((not (pair? p))907 (err "incomplete form") )908 ((not (pair? x)) (err "pair expected"))909 (else910 (walk (car x) (car p))911 (walk (cdr x) (cdr p)) ) ) ) ) )912913914;;; explicit/implicit-renaming transformer915916(define (make-er/ir-transformer handler explicit-renaming?)917 (##sys#make-structure918 'transformer919 (lambda (form se dse)920 (let ((renv '())) ; keep rename-environment for this expansion921 (define (inherit-pair-line-numbers old new)922 (and-let* ((name (car new))923 ((symbol? name))924 (ln (get-line-number old))925 (cur (or (hash-table-ref ##sys#line-number-database name) '())) )926 (unless (assq new cur)927 (hash-table-set! ##sys#line-number-database name928 (alist-weak-cons new ln cur))))929 new)930 (assert (list? se) "not a list" se) ;XXX remove later931 (define (rename sym)932 (cond ((pair? sym)933 (inherit-pair-line-numbers sym (cons (rename (car sym)) (rename (cdr sym)))))934 ((vector? sym)935 (list->vector (rename (vector->list sym))))936 ((not (symbol? sym)) sym)937 ((assq sym renv) =>938 (lambda (a)939 (dd `(RENAME/RENV: ,sym --> ,(cdr a)))940 (cdr a)))941 (else942 (let ((a (macro-alias sym se)))943 (dd `(RENAME: ,sym --> ,a))944 (set! renv (cons (cons sym a) renv))945 a))))946 (define (compare s1 s2)947 (let ((result948 (cond ((pair? s1)949 (and (pair? s2)950 (compare (car s1) (car s2))951 (compare (cdr s1) (cdr s2))))952 ((vector? s1)953 (and (vector? s2)954 (let ((len (vector-length s1)))955 (and (fx= len (vector-length s2))956 (do ((i 0 (fx+ i 1))957 (f #t (compare (vector-ref s1 i) (vector-ref s2 i))))958 ((or (fx>= i len) (not f)) f))))))959 ((and (symbol? s1)960 (symbol? s2))961 (let ((ss1 (or (getp s1 '##core#macro-alias)962 (lookup2 1 s1 dse)963 s1) )964 (ss2 (or (getp s2 '##core#macro-alias)965 (lookup2 2 s2 dse)966 s2) ) )967 (cond ((symbol? ss1)968 (cond ((symbol? ss2) (eq? ss1 ss2))969 ((assq ss1 (##sys#macro-environment)) =>970 (lambda (a) (eq? (cdr a) ss2)))971 (else #f) ) )972 ((symbol? ss2)973 (cond ((assq ss2 (##sys#macro-environment)) =>974 (lambda (a) (eq? ss1 (cdr a))))975 (else #f)))976 (else (eq? ss1 ss2)))))977 (else (eq? s1 s2))) ) )978 (dd `(COMPARE: ,s1 ,s2 --> ,result))979 result))980 (define (lookup2 n sym dse)981 (let ((r (lookup sym dse)))982 (dd " (lookup/DSE " (list n) ": " sym " --> "983 (if (and r (pair? r))984 '<macro>985 r)986 ")")987 r))988 (define (assq-reverse s l)989 (cond990 ((null? l) #f)991 ((eq? (cdar l) s) (car l))992 (else (assq-reverse s (cdr l)))))993 (define (mirror-rename sym)994 (cond ((pair? sym)995 (inherit-pair-line-numbers996 sym (cons (mirror-rename (car sym)) (mirror-rename (cdr sym)))))997 ((vector? sym)998 (list->vector (mirror-rename (vector->list sym))))999 ((not (symbol? sym)) sym)1000 (else ; Code stolen from strip-syntax1001 (let ((renamed (lookup sym se) ) )1002 (cond ((assq-reverse sym renv) =>1003 (lambda (a)1004 (dd "REVERSING RENAME: " sym " --> " (car a)) (car a)))1005 ((not renamed)1006 (dd "IMPLICITLY RENAMED: " sym) (rename sym))1007 ((pair? renamed)1008 (dd "MACRO: " sym) (rename sym))1009 ((getp sym '##core#real-name) =>1010 (lambda (name)1011 (dd "STRIP SYNTAX ON " sym " ---> " name)1012 name))1013 ;; Rename builtin aliases so strip-syntax can still1014 ;; access symbols as entered by the user1015 (else (let ((implicitly-renamed (rename sym)))1016 (dd "BUILTIN ALIAS: " sym " as " renamed1017 " --> " implicitly-renamed)1018 implicitly-renamed)))))))1019 (if explicit-renaming?1020 ;; Let the user handle renaming1021 (handler form rename compare)1022 ;; Implicit renaming:1023 ;; Rename everything in the input first, feed it to the transformer1024 ;; and then swap out all renamed identifiers by their non-renamed1025 ;; versions, and vice versa. User can decide when to inject code1026 ;; unhygienically this way.1027 (mirror-rename (handler (rename form) rename compare)) ) ) )))10281029(define (er-macro-transformer handler) (make-er/ir-transformer handler #t))1030(define (ir-macro-transformer handler) (make-er/ir-transformer handler #f))10311032(define ##sys#er-transformer er-macro-transformer)1033(define ##sys#ir-transformer ir-macro-transformer)103410351036;; Expose some internals for use in core.scm and chicken-syntax.scm:10371038(define chicken.syntax#define-definition define-definition)1039(define chicken.syntax#define-syntax-definition define-syntax-definition)1040(define chicken.syntax#define-values-definition define-values-definition)1041(define chicken.syntax#expansion-result-hook expansion-result-hook)10421043) ; chicken.syntax module10441045(import scheme chicken.base chicken.bytevector chicken.fixnum)1046(import chicken.syntax chicken.internal chicken.platform)1047(import (only (scheme base) make-parameter))10481049;;; Macro definitions:10501051(##sys#extend-macro-environment1052 'import-syntax '()1053 (##sys#er-transformer1054 (cut ##sys#expand-import <> <> <>1055 ##sys#current-environment ##sys#macro-environment1056 #f #f 'import-syntax)))10571058(##sys#extend-macro-environment1059 'import-syntax-for-syntax '()1060 (##sys#er-transformer1061 (cut ##sys#expand-import <> <> <>1062 ##sys#current-meta-environment ##sys#meta-macro-environment1063 #t #f 'import-syntax-for-syntax)))10641065(set! chicken.syntax#import-definition1066 (##sys#extend-macro-environment1067 'import '()1068 (##sys#er-transformer1069 (lambda (x r c)1070 `(##core#begin1071 ,@(map (lambda (x)1072 (let-values (((name lib spec v s i) (##sys#decompose-import x r c 'import))1073 ((mod) (##sys#current-module)))1074 (when (and mod (eq? name (##sys#module-name mod)))1075 (##sys#syntax-error1076 'import "cannot import from module currently being defined" name))1077 (if (not spec)1078 (##sys#syntax-error1079 'import "cannot import from undefined module" name)1080 (##sys#import1081 spec v s i1082 ##sys#current-environment ##sys#macro-environment #f #f 'import))1083 (if (not lib)1084 '(##core#undefined)1085 `(##core#require ,lib ,name))))1086 (cdr x)))))))10871088(##sys#extend-macro-environment1089 'import-for-syntax '()1090 (##sys#er-transformer1091 (lambda (x r c)1092 (##sys#register-meta-expression `(,(r 'import) ,@(cdr x)))1093 `(##core#elaborationtimeonly (,(r 'import) ,@(cdr x))))))10941095(define (process-cond-expand clauses)1096 (define (err x)1097 (##sys#syntax-error "syntax error in `cond-expand' form"1098 x1099 (cons 'cond-expand clauses)))1100 (define (file-exists? fname)1101 (##sys#file-exists? fname #f #f 'cond-expand))1102 (define (locate-library name)1103 (let* ((name2 (library-id name))1104 (sname2 (symbol->string name2)))1105 (or (##sys#find-module name2 #f)1106 (let loop ((rp (repository-path)))1107 (and (pair? rp)1108 (let ((p (car rp)))1109 (or (file-exists? (string-append p "/" sname2 ".import.so"))1110 (file-exists? (string-append p "/" sname2 ".import.scm"))1111 (loop (cdr rp)))))))))1112 (define (test fx)1113 (cond ((symbol? fx) (feature? (strip-syntax fx)))1114 ((not (pair? fx)) (err fx))1115 (else1116 (let ((head (car fx))1117 (rest (cdr fx)))1118 (case (strip-syntax head)1119 ((and)1120 (or (eq? rest '())1121 (if (pair? rest)1122 (and (test (car rest))1123 (test `(and ,@(cdr rest))))1124 (err fx))))1125 ((or)1126 (and (not (eq? rest '()))1127 (if (pair? rest)1128 (or (test (car rest))1129 (test `(or ,@(cdr rest))))1130 (err fx))))1131 ((not) (not (test (cadr fx))))1132 ((library)1133 (if (and (pair? rest)1134 (null? (cdr rest)))1135 (locate-library (strip-syntax (car rest)))1136 (err fx)))1137 (else (err fx)))))))1138 (let expand ((cls clauses))1139 (cond ((eq? cls '())1140 (##sys#apply1141 ##sys#error "no matching clause in `cond-expand' form"1142 (map (lambda (x) (car x)) clauses)))1143 ((not (pair? cls)) (err cls))1144 (else1145 (let ((clause (car cls))1146 (rclauses (cdr cls)))1147 (if (not (pair? clause))1148 (err clause)1149 (let ((id (car clause)))1150 (cond ((eq? (strip-syntax id) 'else)1151 (let ((rest (cdr clause)))1152 (if (eq? rest '())1153 '(##core#undefined)1154 `(##core#begin ,@rest))))1155 ((test id) `(##core#begin ,@(cdr clause)))1156 (else (expand rclauses))))))))))11571158(##sys#extend-macro-environment1159 'cond-expand1160 '()1161 (##sys#er-transformer1162 (lambda (form r c)1163 (process-cond-expand (cdr form)))))11641165;; The "initial" macro environment, containing only import forms and1166;; cond-expand. TODO: Eventually, cond-expand should move to the1167;; (chicken base) module to match r7rs. Keeping it in the initial env1168;; makes it a whole lot easier to write portable CHICKEN 4 & 5 code.1169(define ##sys#initial-macro-environment (##sys#macro-environment))11701171(##sys#extend-macro-environment1172 'module '()1173 (##sys#er-transformer1174 (lambda (x r c)1175 (##sys#check-syntax 'module x '(_ _ _ . #(_ 0)))1176 (let ((len (length x))1177 (name (library-id (cadr x))))1178 ;; We strip syntax here instead of doing a hygienic comparison1179 ;; to "=". This is a tradeoff; either we do this, or we must1180 ;; include a mapping of (= . scheme#=) in our syntax env. In1181 ;; the initial environment, = is bound to scheme#=, but when1182 ;; using -explicit-use that's not the case. Doing an unhygienic1183 ;; comparison ensures module will work in both cases.1184 (cond ((and (fx>= len 4) (eq? '= (strip-syntax (caddr x))))1185 (let* ((x (strip-syntax x))1186 (app (cadddr x)))1187 (cond ((fx> len 4)1188 ;; feature suggested by syn:1189 ;;1190 ;; (module NAME = FUNCTORNAME BODY ...)1191 ;; ~>1192 ;; (begin1193 ;; (module _NAME * BODY ...)1194 ;; (module NAME = (FUNCTORNAME _NAME)))1195 ;;1196 ;; - the use of "_NAME" is a bit stupid, but it must be1197 ;; externally visible to generate an import library from1198 ;; and compiling "NAME" separately may need an import-lib1199 ;; for stuff in "BODY" (say, syntax needed by syntax exported1200 ;; from the functor, or something like this...)1201 (let ((mtmp (string->symbol1202 (##sys#string-append1203 "_"1204 (symbol->string name))))1205 (%module (r 'module)))1206 `(##core#begin1207 (,%module ,mtmp * ,@(cddddr x))1208 (,%module ,name = (,app ,mtmp)))))1209 (else1210 (##sys#check-syntax1211 'module x '(_ _ _ (_ . #(_ 0))))1212 (##sys#instantiate-functor1213 name1214 (library-id (car app))1215 (cdr app)))))) ; functor arguments1216 (else1217 ;;XXX use module name in "loc" argument?1218 (let ((exports (##sys#validate-exports (strip-syntax (caddr x)) 'module)))1219 `(##core#module1220 ,name1221 ,(if (eq? '* exports)1222 #t1223 exports)1224 ,@(let ((body (cdddr x)))1225 (if (and (pair? body)1226 (null? (cdr body))1227 (string? (car body)))1228 `((##core#include ,(car body) ,##sys#current-source-filename))1229 body))))))))))12301231;;; R7RS define-library12321233(##sys#extend-macro-environment1234 'define-library '()1235 (##sys#er-transformer1236 (lambda (x r c)1237 (define (register-r7rs-module name)1238 (let ((dummy (string->symbol (string-append (string #\x04) "r7rs" (symbol->string name)))))1239 (##sys#put! name '##r7rs#module dummy)1240 dummy))1241 (define implicit-r7rs-library-bindings1242 '(begin1243 cond-expand1244 export1245 import1246 import-for-syntax1247 include1248 include-ci1249 syntax-rules))1250 (##sys#check-syntax 'define-library x '(_ . #(_ 0)))1251 (let* ((x (strip-syntax x))1252 (name (cadr x))1253 (real-name (library-id name))1254 (decls (cddr x))1255 (dummy (register-r7rs-module real-name)))1256 (define (parse-exports specs)1257 (map (lambda (spec)1258 (cond ((and (list? spec)1259 (= 3 (length spec))1260 (eq? 'rename (car spec)))1261 `(export/rename ,(cdr spec)))1262 ((symbol? spec) `(export ,spec))1263 (else1264 (##sys#syntax-error 'define-library "invalid export specifier" spec name))))1265 specs))1266 (define (parse-imports specs)1267 ;; XXX TODO: Should be import-for-syntax'ed as well?1268 `(import ,@specs))1269 (define (process-includes fnames ci?)1270 `(##core#begin1271 ,@(map (lambda (fname)1272 (if (string? fname)1273 `(##core#begin ,@(read-forms fname ci?))1274 (##sys#syntax-error 'include "invalid filename"1275 fname)))1276 fnames)))1277 (define (expand/begin e)1278 (let ((e2 (expand e '())))1279 (if (and (pair? e2) (eq? '##core#begin (car e2)))1280 (cons '##core#begin (map expand/begin (cdr e2)))1281 e2)))1282 (define (read-forms filename ci?)1283 (fluid-let ((##sys#default-read-info-hook1284 (let ((name 'chicken.compiler.support#read-info-hook))1285 (and (feature? 'compiling)1286 (##sys#symbol-has-toplevel-binding? name)1287 (##sys#slot name 0)))))1288 (##sys#include-forms-from-file1289 filename1290 ##sys#current-source-filename ci?1291 (lambda (forms path) forms))))1292 (define (process-include-decls fnames)1293 (parse-decls1294 (let loop ((fnames fnames) (all '()))1295 (if (null? fnames)1296 (reverse all)1297 (let ((forms (read-forms (car fnames) #t)))1298 (loop (cdr fnames)1299 (append (reverse forms) all)))))))1300 (define (fail spec)1301 (##sys#syntax-error 'define-library "invalid library declaration" spec))1302 (define (parse-decls decls)1303 (cond ((null? decls) '(##core#begin))1304 ((and (pair? decls) (pair? (car decls)))1305 (let ((spec (car decls))1306 (more (cdr decls)))1307 (case (car spec)1308 ((export)1309 (##sys#check-syntax 'export spec '(_ . #(_ 0)))1310 `(##core#begin ,@(parse-exports (cdr spec))1311 ,(parse-decls more)))1312 ((import)1313 (##sys#check-syntax 'import spec '(_ . #(_ 0)))1314 `(##core#begin ,(parse-imports (cdr spec))1315 ,(parse-decls more)))1316 ((include)1317 (##sys#check-syntax 'include spec '(_ . #(_ 0)))1318 `(##core#begin ,(process-includes (cdr spec) #f)1319 ,(parse-decls more)))1320 ((include-ci)1321 (##sys#check-syntax 'include-ci spec '(_ . #(_ 0)))1322 `(##core#begin ,(process-includes (cdr spec) #t)1323 ,(parse-decls more)))1324 ((include-library-declarations)1325 `(##core#begin ,(process-include-decls (cdr spec))1326 ,(parse-decls more)))1327 ((cond-expand)1328 (parse-decls (append (list (process-cond-expand (cdr spec)))1329 more)))1330 ((##core#begin)1331 (parse-decls (cdr spec)))1332 ((begin)1333 `(##core#begin ,@(cdr spec)1334 ,(parse-decls more)))1335 (else (fail spec)))))1336 (else (fail (car decls)))))1337 `(##core#module ,real-name ((,dummy))1338 ;; gruesome hack: we add a dummy export for adding indirect exports1339 (##core#define-syntax ,dummy1340 (##sys#er-transformer (##core#lambda (x r c) (##core#undefined))))1341 ;; Set up an R7RS environment for the module's body.1342 (import-for-syntax (only scheme.base ,@implicit-r7rs-library-bindings))1343 (import (only scheme.base ,@implicit-r7rs-library-bindings)1344 (only chicken.module export/rename))1345 ;; Now process all toplevel library declarations1346 ,(parse-decls decls))))))13471348(##sys#extend-macro-environment1349 'export '()1350 (##sys#er-transformer1351 (lambda (x r c)1352 (let ((exps (##sys#validate-exports (strip-syntax (cdr x)) 'export))1353 (mod (##sys#current-module)))1354 (when mod1355 (##sys#add-to-export-list mod exps))1356 '(##core#undefined)))))13571358(##sys#extend-macro-environment1359 'export/rename '()1360 (##sys#er-transformer1361 (lambda (x r c)1362 (let ((exps (map (lambda (ren)1363 (if (and (pair? ren)1364 (symbol? (car ren))1365 (pair? (cdr ren))1366 (symbol? (cadr ren))1367 (null? (cddr ren)))1368 (cons (car ren) (cadr ren))1369 (##sys#syntax-error "invalid item in export rename list"1370 ren)))1371 (strip-syntax (cdr x))))1372 (mod (##sys#current-module)))1373 (when mod1374 (##sys#add-to-export/rename-list mod exps))1375 '(##core#undefined)))))13761377(##sys#extend-macro-environment1378 'reexport '()1379 (##sys#er-transformer1380 (cut ##sys#expand-import <> <> <>1381 ##sys#current-environment ##sys#macro-environment1382 #f #t 'reexport)))13831384;;; functor definition13851386(##sys#extend-macro-environment1387 'functor '()1388 (##sys#er-transformer1389 (lambda (x r c)1390 (##sys#check-syntax 'functor x '(_ (_ . #((_ _) 0)) _ . _))1391 (let* ((x (strip-syntax x))1392 (head (cadr x))1393 (name (car head))1394 (args (cdr head))1395 (exps (caddr x))1396 (body (cdddr x))1397 (registration1398 `(##sys#register-functor1399 (##core#quote ,(library-id name))1400 (##core#quote1401 ,(map (lambda (arg)1402 (let ((argname (car arg))1403 (exps (##sys#validate-exports (cadr arg) 'functor)))1404 (unless (or (symbol? argname)1405 (and (list? argname)1406 (= 2 (length argname))1407 (symbol? (car argname))1408 (valid-library-specifier? (cadr argname))))1409 (##sys#syntax-error "invalid functor argument" name arg))1410 (cons argname exps)))1411 args))1412 (##core#quote ,(##sys#validate-exports exps 'functor))1413 (##core#quote ,body))))1414 `(##core#module ,(library-id name)1415 #t1416 (import scheme chicken.syntax) ;; TODO: Is this correct?1417 (begin-for-syntax ,registration))))))14181419;;; interface definition14201421(##sys#extend-macro-environment1422 'define-interface '()1423 (##sys#er-transformer1424 (lambda (x r c)1425 (##sys#check-syntax 'define-interface x '(_ variable _))1426 (let ((name (strip-syntax (cadr x))))1427 (when (eq? '* name)1428 (##sys#syntax-error1429 'define-interface "`*' is not allowed as a name for an interface"))1430 `(##core#elaborationtimeonly1431 (##sys#put/restore!1432 (##core#quote ,name)1433 (##core#quote ##core#interface)1434 (##core#quote1435 ,(let ((exps (strip-syntax (caddr x))))1436 (cond ((eq? '* exps) '*)1437 ((symbol? exps) `(#:interface ,exps))1438 ((list? exps)1439 (##sys#validate-exports exps 'define-interface))1440 (else1441 (##sys#syntax-error1442 'define-interface "invalid exports" (caddr x))))))))))))14431444(##sys#extend-macro-environment1445 'current-module '()1446 (##sys#er-transformer1447 (lambda (x r c)1448 (##sys#check-syntax 'current-module x '(_))1449 (and-let* ((mod (##sys#current-module)))1450 `(##core#quote ,(##sys#module-name mod))))))14511452;; The chicken.module syntax environment1453(define ##sys#chicken.module-macro-environment (##sys#macro-environment))14541455(set! ##sys#scheme-macro-environment1456 (let ((me0 (##sys#macro-environment)))14571458(##sys#extend-macro-environment1459 'lambda1460 '()1461 (##sys#er-transformer1462 (lambda (x r c)1463 (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)))1464 `(##core#lambda ,@(cdr x)))))14651466(##sys#extend-macro-environment1467 'quote1468 '()1469 (##sys#er-transformer1470 (lambda (x r c)1471 (##sys#check-syntax 'quote x '(_ _))1472 `(##core#quote ,(cadr x)))))14731474(##sys#extend-macro-environment1475 'if1476 '()1477 (##sys#er-transformer1478 (lambda (x r c)1479 (##sys#check-syntax 'if x '(_ _ _ . #(_)))1480 `(##core#if ,@(cdr x)))))14811482(##sys#extend-macro-environment1483 'begin1484 '()1485 (##sys#er-transformer1486 (lambda (x r c)1487 (##sys#check-syntax 'begin x '(_ . #(_ 0)))1488 `(##core#begin ,@(cdr x)))))14891490(set! chicken.syntax#define-definition1491 (##sys#extend-macro-environment1492 'define1493 '()1494 (##sys#er-transformer1495 (lambda (x r c)1496 (##sys#check-syntax 'define x '(_ . #(_ 1)))1497 (let loop ((form x))1498 (let ((head (cadr form))1499 (body (cddr form)) )1500 (cond ((not (pair? head))1501 (##sys#check-syntax 'define form '(_ variable . #(_ 0 1)))1502 (let ((name (or (getp head '##core#macro-alias) head)))1503 (##sys#register-export name (##sys#current-module)))1504 (when (c (r 'define) head)1505 (chicken.syntax#defjam-error x))1506 `(##core#begin1507 (##core#ensure-toplevel-definition ,head)1508 (##core#set!1509 ,head1510 ,(if (pair? body) (car body) '(##core#undefined)))))1511 ((pair? (car head))1512 (##sys#check-syntax 'define form '(_ (_ . lambda-list) . #(_ 1)))1513 (loop (chicken.syntax#expand-curried-define head body '()))) ;XXX '() should be se1514 (else1515 (##sys#check-syntax 'define form '(_ (variable . lambda-list) . #(_ 1)))1516 (loop (list (car x) (car head) `(##core#lambda ,(cdr head) ,@body)))))))))))15171518(set! chicken.syntax#define-syntax-definition1519 (##sys#extend-macro-environment1520 'define-syntax1521 '()1522 (##sys#er-transformer1523 (lambda (form r c)1524 (##sys#check-syntax 'define-syntax form '(_ variable _))1525 (let ((head (cadr form))1526 (body (caddr form)))1527 (let ((name (or (getp head '##core#macro-alias) head)))1528 (##sys#register-export name (##sys#current-module)))1529 (when (c (r 'define-syntax) head)1530 (chicken.syntax#defjam-error form))1531 `(##core#define-syntax ,head ,body))))))15321533(##sys#extend-macro-environment1534 'let1535 '()1536 (##sys#er-transformer1537 (lambda (x r c)1538 (cond ((and (pair? (cdr x)) (symbol? (cadr x)))1539 (##sys#check-syntax 'let x '(_ variable #((variable _) 0) . #(_ 1)))1540 (check-for-multiple-bindings (caddr x) x "let"))1541 (else1542 (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)))1543 (check-for-multiple-bindings (cadr x) x "let")))1544 `(##core#let ,@(cdr x)))))15451546(##sys#extend-macro-environment1547 'letrec1548 '()1549 (##sys#er-transformer1550 (lambda (x r c)1551 (##sys#check-syntax 'letrec x '(_ #((variable _) 0) . #(_ 1)))1552 (check-for-multiple-bindings (cadr x) x "letrec")1553 `(##core#letrec ,@(cdr x)))))15541555(##sys#extend-macro-environment1556 'let-syntax1557 '()1558 (##sys#er-transformer1559 (lambda (x r c)1560 (##sys#check-syntax 'let-syntax x '(_ #((variable _) 0) . #(_ 1)))1561 (check-for-multiple-bindings (cadr x) x "let-syntax")1562 `(##core#let-syntax ,@(cdr x)))))15631564(##sys#extend-macro-environment1565 'letrec-syntax1566 '()1567 (##sys#er-transformer1568 (lambda (x r c)1569 (##sys#check-syntax 'letrec-syntax x '(_ #((variable _) 0) . #(_ 1)))1570 (check-for-multiple-bindings (cadr x) x "letrec-syntax")1571 `(##core#letrec-syntax ,@(cdr x)))))15721573(##sys#extend-macro-environment1574 'set!1575 '()1576 (##sys#er-transformer1577 (lambda (x r c)1578 (##sys#check-syntax 'set! x '(_ _ _))1579 (let ((dest (cadr x))1580 (val (caddr x)))1581 (cond ((pair? dest)1582 `((##sys#setter ,(car dest)) ,@(cdr dest) ,val))1583 (else `(##core#set! ,dest ,val)))))))15841585(##sys#extend-macro-environment1586 'and1587 '()1588 (##sys#er-transformer1589 (lambda (form r c)1590 (let ((body (cdr form)))1591 (if (null? body)1592 #t1593 (let ((rbody (cdr body))1594 (hbody (car body)) )1595 (if (null? rbody)1596 hbody1597 `(##core#if ,hbody (,(r 'and) ,@rbody) #f) ) ) ) ) ) ) )15981599(##sys#extend-macro-environment1600 'or1601 '()1602 (##sys#er-transformer1603 (lambda (form r c)1604 (let ((body (cdr form)))1605 (if (null? body)1606 #f1607 (let ((rbody (cdr body))1608 (hbody (car body)))1609 (if (null? rbody)1610 hbody1611 (let ((tmp (r 'tmp)))1612 `(##core#let ((,tmp ,hbody))1613 (##core#if ,tmp ,tmp (,(r 'or) ,@rbody)) ) ) ) ) ) ) ) ) )16141615(##sys#extend-macro-environment1616 'cond1617 '()1618 (##sys#er-transformer1619 (lambda (form r c)1620 (let ((body (cdr form))1621 (%=> (r '=>))1622 (%or (r 'or))1623 (%else (r 'else)))1624 (let expand ((clauses body) (else? #f))1625 (if (not (pair? clauses))1626 '(##core#undefined)1627 (let ((clause (car clauses))1628 (rclauses (cdr clauses)) )1629 (##sys#check-syntax 'cond clause '#(_ 1))1630 (cond (else?1631 (##sys#warn1632 (chicken.format#sprintf "clause following `~S' clause in `cond'" else?)1633 (strip-syntax clause))1634 (expand rclauses else?)1635 '(##core#begin))1636 ((or (c %else (car clause))1637 (eq? #t (car clause))1638 ;; Like "constant?" from support.scm1639 (number? (car clause))1640 (char? (car clause))1641 (string? (car clause))1642 (eof-object? (car clause))1643 (bytevector? (car clause))1644 (bwp-object? (car clause))1645 (vector? (car clause))1646 (##sys#srfi-4-vector? (car clause))1647 (and (pair? (car clause))1648 (c (r 'quote) (caar clause))))1649 (expand rclauses (strip-syntax (car clause)))1650 (cond ((and (fx= (length clause) 3)1651 (c %=> (cadr clause)))1652 `(,(caddr clause) ,(car clause)))1653 ((pair? (cdr clause))1654 `(##core#begin ,@(cdr clause)))1655 ((c %else (car clause))1656 `(##core#undefined))1657 (else (car clause))))1658 ((null? (cdr clause))1659 `(,%or ,(car clause) ,(expand rclauses #f)))1660 ((and (fx= (length clause) 3)1661 (c %=> (cadr clause)))1662 (let ((tmp (r 'tmp)))1663 `(##core#let ((,tmp ,(car clause)))1664 (##core#if ,tmp1665 (,(caddr clause) ,tmp)1666 ,(expand rclauses #f) ) ) ) )1667 ((and (fx= (length clause) 4)1668 (c %=> (caddr clause)))1669 (let ((tmp (r 'tmp)))1670 `(##sys#call-with-values1671 (##core#lambda () ,(car clause))1672 (##core#lambda1673 ,tmp1674 (if (##sys#apply ,(cadr clause) ,tmp)1675 (##sys#apply ,(cadddr clause) ,tmp)1676 ,(expand rclauses #f) ) ) ) ) )1677 (else `(##core#if ,(car clause)1678 (##core#begin ,@(cdr clause))1679 ,(expand rclauses #f) ) ) ) ) ) ) ) ) ) )16801681(##sys#extend-macro-environment1682 'case1683 '((eqv? . scheme#eqv?))1684 (##sys#er-transformer1685 (lambda (form r c)1686 (##sys#check-syntax 'case form '(_ _ . #(_ 0)))1687 (let ((exp (cadr form))1688 (body (cddr form)) )1689 (let ((tmp (r 'tmp))1690 (%or (r 'or))1691 (%=> (r '=>))1692 (%eqv? (r 'eqv?))1693 (%else (r 'else)))1694 `(let ((,tmp ,exp))1695 ,(let expand ((clauses body) (else? #f))1696 (if (not (pair? clauses))1697 '(##core#undefined)1698 (let ((clause (car clauses))1699 (rclauses (cdr clauses)) )1700 (##sys#check-syntax 'case clause '#(_ 1))1701 (cond (else?1702 (##sys#warn1703 "clause following `else' clause in `case'"1704 (strip-syntax clause))1705 (expand rclauses #t)1706 '(##core#begin))1707 ((c %else (car clause))1708 (expand rclauses #t)1709 (cond ((null? (cdr clause))1710 `(##core#undefined))1711 ((and (fx= (length clause) 3) ; (else => expr)1712 (c %=> (cadr clause)))1713 `(,(caddr clause) ,tmp))1714 (else1715 `(##core#begin ,@(cdr clause)))))1716 (else1717 `(##core#if (,%or ,@(##sys#map1718 (lambda (x) `(,%eqv? ,tmp ',x))1719 (car clause)))1720 ,(if (and (fx= (length clause) 3) ; ((...) => expr)1721 (c %=> (cadr clause)))1722 `(,(caddr clause) ,tmp)1723 `(##core#begin ,@(cdr clause)))1724 ,(expand rclauses #f) ) ) ) ) ) ) ) ) ) ) ) )17251726(##sys#extend-macro-environment1727 'let*1728 '()1729 (##sys#er-transformer1730 (lambda (form r c)1731 (##sys#check-syntax 'let* form '(_ #((variable _) 0) . #(_ 1)))1732 (let ((bindings (cadr form))1733 (body (cddr form)) )1734 (let expand ((bs bindings))1735 (if (eq? bs '())1736 `(##core#let () ,@body)1737 `(##core#let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) ) )17381739(##sys#extend-macro-environment1740 'do1741 '()1742 (##sys#er-transformer1743 (lambda (form r c)1744 (##sys#check-syntax 'do form '(_ #((variable _ . #(_)) 0) . #(_ 1)))1745 (let ((bindings (cadr form))1746 (test (caddr form))1747 (body (cdddr form))1748 (dovar (r 'doloop)))1749 `(##core#let1750 ,dovar1751 ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)1752 (##core#if ,(car test)1753 ,(let ((tbody (cdr test)))1754 (if (eq? tbody '())1755 '(##core#undefined)1756 `(##core#begin ,@tbody) ) )1757 (##core#begin1758 ,(if (eq? body '())1759 '(##core#undefined)1760 `(##core#let () ,@body) )1761 (##core#app1762 ,dovar ,@(##sys#map (lambda (b)1763 (if (eq? (cdr (cdr b)) '())1764 (car b)1765 (car (cdr (cdr b))) ) )1766 bindings) ) ) ) ) ) ) ) )17671768(##sys#extend-macro-environment1769 'quasiquote1770 '()1771 (##sys#er-transformer1772 (lambda (form r c)1773 (let ((%quasiquote (r 'quasiquote))1774 (%unquote (r 'unquote))1775 (%unquote-splicing (r 'unquote-splicing)))1776 (define (walk x n) (simplify (walk1 x n)))1777 (define (walk1 x n)1778 (cond ((vector? x)1779 `(##sys#list->vector ,(walk (vector->list x) n)) )1780 ((not (pair? x)) `(##core#quote ,x))1781 (else1782 (let ((head (car x))1783 (tail (cdr x)))1784 (cond ((c %unquote head)1785 (cond ((eq? n 0)1786 (##sys#check-syntax 'unquote x '(_ _))1787 (car tail))1788 (else (list '##sys#cons `(##core#quote ,%unquote)1789 (walk tail (fx- n 1)) ) )))1790 ((c %quasiquote head)1791 (list '##sys#cons `(##core#quote ,%quasiquote)1792 (walk tail (fx+ n 1)) ) )1793 ((and (pair? head) (c %unquote-splicing (car head)))1794 (cond ((eq? n 0)1795 (##sys#check-syntax 'unquote-splicing head '(_ _))1796 `(##sys#append ,(cadr head) ,(walk tail n)))1797 (else1798 `(##sys#cons1799 (##sys#cons (##core#quote ,%unquote-splicing)1800 ,(walk (cdr head) (fx- n 1)) )1801 ,(walk tail n)))))1802 (else1803 `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )1804 (define (simplify x)1805 (cond ((chicken.syntax#match-expression x '(##sys#cons a (##core#quote ())) '(a))1806 => (lambda (env) (simplify `(##sys#list ,(cdr (assq 'a env))))) )1807 ((chicken.syntax#match-expression x '(##sys#cons a (##sys#list . b)) '(a b))1808 => (lambda (env)1809 (let ((bxs (assq 'b env)))1810 (if (fx< (length bxs) 32)1811 (simplify `(##sys#list ,(cdr (assq 'a env))1812 ,@(cdr bxs) ) )1813 x) ) ) )1814 ((chicken.syntax#match-expression x '(##sys#append a (##core#quote ())) '(a))1815 => (lambda (env) (cdr (assq 'a env))) )1816 (else x) ) )1817 (##sys#check-syntax 'quasiquote form '(_ _))1818 (walk (cadr form) 0) ) ) ) )18191820(##sys#extend-macro-environment1821 'delay1822 '()1823 (##sys#er-transformer1824 (lambda (form r c)1825 (##sys#check-syntax 'delay form '(_ _))1826 `(,(r 'delay-force)1827 (##sys#make-promise1828 (##sys#call-with-values (##core#lambda () ,(cadr form)) ##sys#list))))))18291830(##sys#extend-macro-environment1831 'syntax-error1832 '()1833 (##sys#er-transformer1834 (lambda (form r c)1835 (##sys#check-syntax 'syntax-error form '(_ string . #(_ 0)))1836 (apply ##sys#syntax-error (cadr form) (cddr form)))))18371838;;; syntax-rules18391840(include "synrules.scm")18411842(macro-subset me0)))18431844;;; the base macro environment (the old "scheme", essentially)1845;;; TODO: Remove this18461847(define ##sys#default-macro-environment1848 (fixup-macro-environment (##sys#macro-environment)))18491850(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))18511852;; register features18531854(register-feature! 'srfi-0 'srfi-46 'srfi-61 'srfi-87)