~ chicken-core (chicken-5) /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 syntax-error43 er-macro-transformer44 ir-macro-transformer)4546(import scheme47 chicken.base48 chicken.condition49 chicken.fixnum50 chicken.internal51 chicken.keyword52 chicken.platform53 chicken.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#slot name 1)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-error-hook233 (string-append234 "syntax transformer for `" (symbol->string 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 (cond ((not (list? exp))250 (##sys#syntax-error-hook "invalid syntax in macro form" exp) )251 ((pair? mdef)252 (values253 ;; force ref. opaqueness by passing dynamic se [what does this comment mean? I forgot ...]254 (call-handler head (cadr mdef) exp (car mdef) #f)255 #t))256 (else (values exp #f)) ) )257 (let loop ((exp exp))258 (if (pair? exp)259 (let ((head (car exp))260 (body (cdr exp)) )261 (if (symbol? head)262 (let ((head2 (or (lookup head dse) head)))263 (unless (pair? head2)264 (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )265 (cond ((and (pair? head2)266 (eq? (##sys#get head '##sys#override) 'value))267 (values exp #f))268 ((eq? head2 '##core#let)269 (##sys#check-syntax 'let body '#(_ 2) #f dse)270 (let ((bindings (car body)))271 (cond ((symbol? bindings) ; expand named let272 (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)273 (let ([bs (cadr body)])274 (values275 `(##core#app276 (##core#letrec*277 ([,bindings278 (##core#loop-lambda279 ,(map (lambda (b) (car b)) bs) ,@(cddr body))])280 ,bindings)281 ,@(##sys#map cadr bs) )282 #t) ) )283 (else (values exp #f)) ) ) )284 ((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) =>285 (lambda (cs)286 (let ((result (call-handler head (car cs) exp (cdr cs) #t)))287 (cond ((eq? result exp) (expand head exp head2))288 (else289 (when ##sys#compiler-syntax-hook290 (##sys#compiler-syntax-hook head2 result))291 (loop result))))))292 (else (expand head exp head2)) ) )293 (values exp #f) ) )294 (values exp #f) ) ) )295296(define ##sys#compiler-syntax-hook #f)297(define ##sys#enable-runtime-macros #f)298(define expansion-result-hook (lambda (input output) output))299300301;;; User-level macroexpansion302303(define (expand exp #!optional (se (##sys#current-environment)) cs?)304 (let loop ((exp exp))305 (let-values (((exp2 m) (##sys#expand-0 exp se cs?)))306 (if m307 (loop exp2)308 exp2) ) ) )309310311;;; Extended (DSSSL-style) lambda lists312;313; Assumptions:314;315; 1) #!rest must come before #!key316; 2) default values may refer to earlier variables317; 3) optional/key args may be either variable or (variable default)318; 4) an argument marker may not be specified more than once319; 5) no special handling of extra keywords (no error)320; 6) default value of optional/key args is #f321; 7) mixing with dotted list syntax is allowed322323(define (##sys#extended-lambda-list? llist)324 (let loop ([llist llist])325 (and (pair? llist)326 (case (##sys#slot llist 0)327 [(#!rest #!optional #!key) #t]328 [else (loop (cdr llist))] ) ) ) )329330(define ##sys#expand-extended-lambda-list331 (let ((reverse reverse))332 (lambda (llist0 body errh se)333 (define (err msg) (errh msg llist0))334 (define (->keyword s) (string->keyword (##sys#slot s 1)))335 (let ((rvar #f)336 (hasrest #f)337 ;; These might not exist in se, use default or chicken env:338 (%let* (macro-alias 'let* ##sys#default-macro-environment))339 (%lambda '##core#lambda)340 (%opt (macro-alias 'optional ##sys#chicken.base-macro-environment))341 (%let-optionals* (macro-alias 'let-optionals* ##sys#chicken.base-macro-environment))342 (%let '##core#let))343 (let loop ([mode 0] ; req=0, opt=1, rest=2, key=3, end=4344 [req '()]345 [opt '()]346 [key '()]347 [llist llist0] )348 (cond [(null? llist)349 (values350 (if rvar (##sys#append (reverse req) rvar) (reverse req))351 (let ([body352 (if (null? key)353 body354 `((,%let*355 ,(map (lambda (k)356 (let ([s (car k)])357 `(,s (##sys#get-keyword358 (##core#quote ,(->keyword (strip-syntax s))) ,(or hasrest rvar)359 ,@(if (pair? (cdr k))360 `((,%lambda () ,@(cdr k)))361 '())))))362 (reverse key) )363 ,@body) ) ) ] )364 (cond [(null? opt) body]365 [(and (not hasrest) (null? key) (null? (cdr opt)))366 `((,%let367 ([,(caar opt) (,%opt ,rvar ,(cadar opt))])368 ,@body) ) ]369 [(and (not hasrest) (null? key))370 `((,%let-optionals*371 ,rvar ,(reverse opt) ,@body))]372 [else373 `((,%let-optionals*374 ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar)))375 ,@body))] ) ) ) ]376 [(symbol? llist)377 (if (fx> mode 2)378 (err "rest argument list specified more than once")379 (begin380 (unless rvar (set! rvar llist))381 (set! hasrest llist)382 (loop 4 req opt '() '()) ) ) ]383 [(not (pair? llist))384 (err "invalid lambda list syntax") ]385 [else386 (let* ((var (car llist))387 (x (or (and (symbol? var) (not (eq? 3 mode)) (lookup var se)) var))388 (r (cdr llist)))389 (case x390 [(#!optional)391 (unless rvar (set! rvar (macro-alias 'rest se)))392 (if (eq? mode 0)393 (loop 1 req '() '() r)394 (err "`#!optional' argument marker in wrong context") ) ]395 [(#!rest)396 (if (fx<= mode 1)397 (if (and (pair? r) (symbol? (car r)))398 (begin399 (if (not rvar) (set! rvar (car r)))400 (set! hasrest (car r))401 (loop 2 req opt '() (cdr r)) )402 (err "invalid syntax of `#!rest' argument") )403 (err "`#!rest' argument marker in wrong context") ) ]404 [(#!key)405 (if (not rvar) (set! rvar (macro-alias 'rest se)))406 (if (fx<= mode 2)407 (loop 3 req opt '() r)408 (err "`#!key' argument marker in wrong context") ) ]409 [else410 (cond [(symbol? var)411 (case mode412 [(0) (loop 0 (cons var req) '() '() r)]413 [(1) (loop 1 req (cons (list var #f) opt) '() r)]414 [(2) (err "invalid lambda list syntax after `#!rest' marker")]415 [else (loop 3 req opt (cons (list var) key) r)] ) ]416 [(and (list? var) (eq? 2 (length var)) (symbol? (car var)))417 (case mode418 [(0) (err "invalid required argument syntax")]419 [(1) (loop 1 req (cons var opt) '() r)]420 [(2) (err "invalid lambda list syntax after `#!rest' marker")]421 [else (loop 3 req opt (cons var key) r)] ) ]422 [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )423424425;;; Error message for redefinition of currently used defining form426;427; (i.e.`"(define define ...)")428429(define (defjam-error form)430 (##sys#syntax-error-hook431 "redefinition of currently used defining form" ; help me find something better432 form))433434;;; Expansion of multiple values assignments.435;436; Given a lambda list and a multi-valued expression, returns a form that437; will `set!` each variable to its corresponding value in order.438439(define (##sys#expand-multiple-values-assignment formals expr)440 (##sys#decompose-lambda-list441 formals442 (lambda (vars argc rest)443 (let ((aliases (if (symbol? formals) '() (map gensym formals)))444 (rest-alias (if (not rest) '() (gensym rest))))445 `(##sys#call-with-values446 (##core#lambda () ,expr)447 (##core#lambda448 ,(append aliases rest-alias)449 ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases)450 ,@(cond451 ((null? formals) '((##core#undefined)))452 ((null? rest-alias) '())453 (else `((##core#set! ,rest ,rest-alias))))))))))454455;;; Expansion of bodies (and internal definitions)456;457; This code is disgustingly complex.458459(define define-definition)460(define define-syntax-definition)461(define define-values-definition)462(define import-definition)463464(define ##sys#canonicalize-body465 (lambda (body #!optional (se (##sys#current-environment)) cs?)466 (define (comp s id)467 (let ((f (or (lookup id se)468 (lookup id (##sys#macro-environment)))))469 (and (or (not (symbol? f))470 (not (eq? (##sys#get id '##sys#override) 'value)))471 (or (eq? f s) (eq? s id)))))472 (define (comp-def def)473 (lambda (id)474 (let repeat ((id id))475 (let ((f (or (lookup id se)476 (lookup id (##sys#macro-environment)))))477 (and (or (not (symbol? f))478 (not (eq? (##sys#get id '##sys#override) 'value)))479 (or (eq? f def)480 (and (symbol? f)481 (not (eq? f id))482 (repeat f))))))))483 (define comp-define (comp-def define-definition))484 (define comp-define-syntax (comp-def define-syntax-definition))485 (define comp-define-values (comp-def define-values-definition))486 (define comp-import (comp-def import-definition))487 (define (fini vars vals mvars body)488 (if (and (null? vars) (null? mvars))489 ;; Macro-expand body, and restart when defines are found.490 (let loop ((body body) (exps '()))491 (if (not (pair? body))492 (cons493 '##core#begin494 (reverse exps)) ; no more defines, otherwise we would have called `expand'495 (let loop2 ((body body))496 (let ((x (car body))497 (rest (cdr body)))498 (if (and (pair? x)499 (let ((d (car x)))500 (and (symbol? d)501 (or (comp '##core#begin d)502 (comp-define d)503 (comp-define-values d)504 (comp-define-syntax d)505 (comp-import d)))))506 ;; Stupid hack to avoid expanding imports507 (if (comp-import (car x))508 (loop rest (cons x exps))509 (cons510 '##core#begin511 (##sys#append (reverse exps) (list (expand body)))))512 (let ((x2 (##sys#expand-0 x se cs?)))513 (if (eq? x x2)514 ;; Modules and includes must be processed before515 ;; we can continue with other forms, so hand516 ;; control back to the compiler517 (if (and (pair? x)518 (symbol? (car x))519 (or (comp '##core#module (car x))520 (comp '##core#include (car x))))521 `(##core#begin522 ,@(reverse exps)523 ,@(if (comp '##core#module (car x))524 (if (null? rest)525 `(,x)526 `(,x (##core#let () ,@rest)))527 `((##core#include ,@(cdr x) ,rest))))528 (loop rest (cons x exps)))529 (loop2 (cons x2 rest)) )) ))) ))530 ;; We saw defines. Translate to letrec, and let compiler531 ;; call us again for the remaining body by wrapping the532 ;; remaining body forms in a ##core#let.533 (let* ((result534 `(##core#let535 ,(##sys#map536 (lambda (v) (##sys#list v '(##core#undefined)))537 ;; vars are all normalised to lambda-lists: flatten them538 (foldl (lambda (l v)539 (##sys#append l (##sys#decompose-lambda-list540 v (lambda (a _ _) a))))541 '()542 (reverse vars))) ; not strictly necessary...543 ,@(map (lambda (var val is-mvar?)544 ;; Non-mvars should expand to set! for545 ;; efficiency, but also because they must be546 ;; implicit multi-value continuations.547 (if is-mvar?548 (##sys#expand-multiple-values-assignment var val)549 `(##core#set! ,(car var) ,val)))550 (reverse vars)551 (reverse vals)552 (reverse mvars))553 ,@body) ) )554 (dd `(BODY: ,result))555 result)))556 (define (fini/syntax vars vals mvars body)557 (fini558 vars vals mvars559 (let loop ((body body) (defs '()) (done #f))560 (cond (done `((##core#letrec-syntax561 ,(map cdr (reverse defs)) ,@body) ))562 ((not (pair? body)) (loop body defs #t))563 ((and (list? (car body))564 (>= 3 (length (car body)))565 (symbol? (caar body))566 (comp-define-syntax (caar body)))567 (let ((def (car body)))568 ;; This check is insufficient, if introduced by569 ;; different expansions, but better than nothing:570 (when (eq? (car def) (cadr def))571 (defjam-error def))572 (loop (cdr body) (cons def defs) #f)))573 (else (loop body defs #t))))))574 ;; Expand a run of defines or define-syntaxes into letrec. As575 ;; soon as we encounter something else, finish up.576 (define (expand body)577 ;; Each #t in "mvars" indicates an MV-capable "var". Non-MV578 ;; vars (#f in mvars) are 1-element lambda-lists for simplicity.579 (let loop ((body body) (vars '()) (vals '()) (mvars '()))580 (d "BODY: " body)581 (if (not (pair? body))582 (fini vars vals mvars body)583 (let* ((x (car body))584 (rest (cdr body))585 (exp1 (and (pair? x) (car x)))586 (head (and exp1 (symbol? exp1) exp1)))587 (if (not (symbol? head))588 (fini vars vals mvars body)589 (cond590 ((comp-define head)591 (##sys#check-syntax 'define x '(_ _ . #(_ 0)) #f se)592 (let loop2 ((x x))593 (let ((head (cadr x)))594 (cond ((not (pair? head))595 (##sys#check-syntax 'define x '(_ variable . #(_ 0)) #f se)596 (when (eq? (car x) head) ; see above597 (defjam-error x))598 (loop rest (cons (list head) vars)599 (cons (if (pair? (cddr x))600 (caddr x)601 '(##core#undefined) )602 vals)603 (cons #f mvars)))604 ((pair? (car head))605 (##sys#check-syntax606 'define x '(_ (_ . lambda-list) . #(_ 1)) #f se)607 (loop2608 (chicken.syntax#expand-curried-define head (cddr x) se)))609 (else610 (##sys#check-syntax611 'define x612 '(_ (variable . lambda-list) . #(_ 1)) #f se)613 (loop rest614 (cons (list (car head)) vars)615 (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)616 (cons #f mvars)))))))617 ((comp-define-syntax head)618 (##sys#check-syntax 'define-syntax x '(_ _ . #(_ 1)) se)619 (fini/syntax vars vals mvars body))620 ((comp-define-values head)621 ;;XXX check for any of the variables being `define-values'622 (##sys#check-syntax 'define-values x '(_ lambda-list _) #f se)623 (loop rest (cons (cadr x) vars) (cons (caddr x) vals) (cons #t mvars)))624 ((comp '##core#begin head)625 (loop (##sys#append (cdr x) rest) vars vals mvars))626 (else627 ;; Do not macro-expand local definitions we are628 ;; in the process of introducing.629 (if (member (list head) vars)630 (fini vars vals mvars body)631 (let ((x2 (##sys#expand-0 x se cs?)))632 (if (eq? x x2)633 (fini vars vals mvars body)634 (loop (cons x2 rest) vars vals mvars)))))))))))635 (expand body) ) )636637638;;; A simple expression matcher639640;; Used by "quasiquote", below641(define chicken.syntax#match-expression642 (lambda (exp pat vars)643 (let ((env '()))644 (define (mwalk x p)645 (cond ((not (pair? p))646 (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))647 ((memq p vars)648 (set! env (cons (cons p x) env))649 #t)650 (else (eq? x p)) ) )651 ((pair? x)652 (and (mwalk (car x) (car p))653 (mwalk (cdr x) (cdr p)) ) )654 (else #f) ) )655 (and (mwalk exp pat) env) ) ) )656657658;;; Expand "curried" lambda-list syntax for `define'659660;; Used by "define", below661(define (chicken.syntax#expand-curried-define head body se)662 (let ((name #f))663 (define (loop head body)664 (if (symbol? (car head))665 (begin666 (set! name (car head))667 `(##core#lambda ,(cdr head) ,@body) )668 (loop (car head) `((##core#lambda ,(cdr head) ,@body)) ) ))669 (let ([exp (loop head body)])670 (list 'define name exp) ) ) )671672673;;; Line-number database management:674675(define ##sys#line-number-database #f)676677;;; General syntax checking routine:678679(define ##sys#syntax-error-culprit #f)680(define ##sys#syntax-context '())681682(define (syntax-error . args)683 (apply ##sys#signal-hook #:syntax-error684 (strip-syntax args)))685686(define ##sys#syntax-error-hook syntax-error)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 (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-error-hook837 (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.blob chicken.fixnum)1042(import chicken.syntax chicken.internal chicken.platform)10431044;;; Macro definitions:10451046(##sys#extend-macro-environment1047 'import-syntax '()1048 (##sys#er-transformer1049 (cut ##sys#expand-import <> <> <>1050 ##sys#current-environment ##sys#macro-environment1051 #f #f 'import-syntax)))10521053(##sys#extend-macro-environment1054 'import-syntax-for-syntax '()1055 (##sys#er-transformer1056 (cut ##sys#expand-import <> <> <>1057 ##sys#current-meta-environment ##sys#meta-macro-environment1058 #t #f 'import-syntax-for-syntax)))10591060(set! chicken.syntax#import-definition1061 (##sys#extend-macro-environment1062 'import '()1063 (##sys#er-transformer1064 (lambda (x r c)1065 `(##core#begin1066 ,@(map (lambda (x)1067 (let-values (((name lib spec v s i) (##sys#decompose-import x r c 'import))1068 ((mod) (##sys#current-module)))1069 (when (and mod (eq? name (##sys#module-name mod)))1070 (##sys#syntax-error-hook1071 'import "cannot import from module currently being defined" name))1072 (if (not spec)1073 (##sys#syntax-error-hook1074 'import "cannot import from undefined module" name)1075 (##sys#import1076 spec v s i1077 ##sys#current-environment ##sys#macro-environment #f #f 'import))1078 (if (not lib)1079 '(##core#undefined)1080 `(##core#require ,lib ,name))))1081 (cdr x)))))))10821083(##sys#extend-macro-environment1084 'import-for-syntax '()1085 (##sys#er-transformer1086 (lambda (x r c)1087 (##sys#register-meta-expression `(,(r 'import) ,@(cdr x)))1088 `(##core#elaborationtimeonly (,(r 'import) ,@(cdr x))))))108910901091(##sys#extend-macro-environment1092 'cond-expand1093 '()1094 (##sys#er-transformer1095 (lambda (form r c)1096 (let ((clauses (cdr form)))1097 (define (err x)1098 (##sys#error "syntax error in `cond-expand' form"1099 x1100 (cons 'cond-expand clauses)))1101 (define (test fx)1102 (cond ((symbol? fx) (feature? (strip-syntax fx)))1103 ((not (pair? fx)) (err fx))1104 (else1105 (let ((head (car fx))1106 (rest (cdr fx)))1107 (case (strip-syntax head)1108 ((and)1109 (or (eq? rest '())1110 (if (pair? rest)1111 (and (test (car rest))1112 (test `(and ,@(cdr rest))))1113 (err fx))))1114 ((or)1115 (and (not (eq? rest '()))1116 (if (pair? rest)1117 (or (test (car rest))1118 (test `(or ,@(cdr rest))))1119 (err fx))))1120 ((not) (not (test (cadr fx))))1121 (else (err fx)))))))1122 (let expand ((cls clauses))1123 (cond ((eq? cls '())1124 (##sys#apply1125 ##sys#error "no matching clause in `cond-expand' form"1126 (map (lambda (x) (car x)) clauses)))1127 ((not (pair? cls)) (err cls))1128 (else1129 (let ((clause (car cls))1130 (rclauses (cdr cls)))1131 (if (not (pair? clause))1132 (err clause)1133 (let ((id (car clause)))1134 (cond ((eq? (strip-syntax id) 'else)1135 (let ((rest (cdr clause)))1136 (if (eq? rest '())1137 '(##core#undefined)1138 `(##core#begin ,@rest))))1139 ((test id) `(##core#begin ,@(cdr clause)))1140 (else (expand rclauses)))))))))))))11411142;; The "initial" macro environment, containing only import forms and1143;; cond-expand. TODO: Eventually, cond-expand should move to the1144;; (chicken base) module to match r7rs. Keeping it in the initial env1145;; makes it a whole lot easier to write portable CHICKEN 4 & 5 code.1146(define ##sys#initial-macro-environment (##sys#macro-environment))11471148(##sys#extend-macro-environment1149 'module '()1150 (##sys#er-transformer1151 (lambda (x r c)1152 (##sys#check-syntax 'module x '(_ _ _ . #(_ 0)))1153 (let ((len (length x))1154 (name (library-id (cadr x))))1155 ;; We strip syntax here instead of doing a hygienic comparison1156 ;; to "=". This is a tradeoff; either we do this, or we must1157 ;; include a mapping of (= . scheme#=) in our syntax env. In1158 ;; the initial environment, = is bound to scheme#=, but when1159 ;; using -explicit-use that's not the case. Doing an unhygienic1160 ;; comparison ensures module will work in both cases.1161 (cond ((and (fx>= len 4) (eq? '= (strip-syntax (caddr x))))1162 (let* ((x (strip-syntax x))1163 (app (cadddr x)))1164 (cond ((fx> len 4)1165 ;; feature suggested by syn:1166 ;;1167 ;; (module NAME = FUNCTORNAME BODY ...)1168 ;; ~>1169 ;; (begin1170 ;; (module _NAME * BODY ...)1171 ;; (module NAME = (FUNCTORNAME _NAME)))1172 ;;1173 ;; - the use of "_NAME" is a bit stupid, but it must be1174 ;; externally visible to generate an import library from1175 ;; and compiling "NAME" separately may need an import-lib1176 ;; for stuff in "BODY" (say, syntax needed by syntax exported1177 ;; from the functor, or something like this...)1178 (let ((mtmp (string->symbol1179 (##sys#string-append1180 "_"1181 (symbol->string name))))1182 (%module (r 'module)))1183 `(##core#begin1184 (,%module ,mtmp * ,@(cddddr x))1185 (,%module ,name = (,app ,mtmp)))))1186 (else1187 (##sys#check-syntax1188 'module x '(_ _ _ (_ . #(_ 0))))1189 (##sys#instantiate-functor1190 name1191 (library-id (car app))1192 (cdr app)))))) ; functor arguments1193 (else1194 ;;XXX use module name in "loc" argument?1195 (let ((exports (##sys#validate-exports (strip-syntax (caddr x)) 'module)))1196 `(##core#module1197 ,name1198 ,(if (eq? '* exports)1199 #t1200 exports)1201 ,@(let ((body (cdddr x)))1202 (if (and (pair? body)1203 (null? (cdr body))1204 (string? (car body)))1205 `((##core#include ,(car body) ,##sys#current-source-filename))1206 body))))))))))12071208(##sys#extend-macro-environment1209 'export '()1210 (##sys#er-transformer1211 (lambda (x r c)1212 (let ((exps (##sys#validate-exports (strip-syntax (cdr x)) 'export))1213 (mod (##sys#current-module)))1214 (when mod1215 (##sys#add-to-export-list mod exps))1216 '(##core#undefined)))))12171218(##sys#extend-macro-environment1219 'export/rename '()1220 (##sys#er-transformer1221 (lambda (x r c)1222 (let ((exps (map (lambda (ren)1223 (if (and (pair? ren)1224 (symbol? (car ren))1225 (pair? (cdr ren))1226 (symbol? (cadr ren))1227 (null? (cddr ren)))1228 (cons (car ren) (cadr ren))1229 (##sys#syntax-error-hook "invalid item in export rename list"1230 ren)))1231 (strip-syntax (cdr x))))1232 (mod (##sys#current-module)))1233 (when mod1234 (##sys#add-to-export/rename-list mod exps))1235 '(##core#undefined)))))12361237(##sys#extend-macro-environment1238 'reexport '()1239 (##sys#er-transformer1240 (cut ##sys#expand-import <> <> <>1241 ##sys#current-environment ##sys#macro-environment1242 #f #t 'reexport)))12431244;;; functor definition12451246(##sys#extend-macro-environment1247 'functor '()1248 (##sys#er-transformer1249 (lambda (x r c)1250 (##sys#check-syntax 'functor x '(_ (_ . #((_ _) 0)) _ . _))1251 (let* ((x (strip-syntax x))1252 (head (cadr x))1253 (name (car head))1254 (args (cdr head))1255 (exps (caddr x))1256 (body (cdddr x))1257 (registration1258 `(##sys#register-functor1259 (##core#quote ,(library-id name))1260 (##core#quote1261 ,(map (lambda (arg)1262 (let ((argname (car arg))1263 (exps (##sys#validate-exports (cadr arg) 'functor)))1264 (unless (or (symbol? argname)1265 (and (list? argname)1266 (= 2 (length argname))1267 (symbol? (car argname))1268 (valid-library-specifier? (cadr argname))))1269 (##sys#syntax-error-hook "invalid functor argument" name arg))1270 (cons argname exps)))1271 args))1272 (##core#quote ,(##sys#validate-exports exps 'functor))1273 (##core#quote ,body))))1274 `(##core#module ,(library-id name)1275 #t1276 (import scheme chicken.syntax) ;; TODO: Is this correct?1277 (begin-for-syntax ,registration))))))12781279;;; interface definition12801281(##sys#extend-macro-environment1282 'define-interface '()1283 (##sys#er-transformer1284 (lambda (x r c)1285 (##sys#check-syntax 'define-interface x '(_ variable _))1286 (let ((name (strip-syntax (cadr x))))1287 (when (eq? '* name)1288 (syntax-error-hook1289 'define-interface "`*' is not allowed as a name for an interface"))1290 `(##core#elaborationtimeonly1291 (##sys#put/restore!1292 (##core#quote ,name)1293 (##core#quote ##core#interface)1294 (##core#quote1295 ,(let ((exps (strip-syntax (caddr x))))1296 (cond ((eq? '* exps) '*)1297 ((symbol? exps) `(#:interface ,exps))1298 ((list? exps)1299 (##sys#validate-exports exps 'define-interface))1300 (else1301 (syntax-error-hook1302 'define-interface "invalid exports" (caddr x))))))))))))13031304(##sys#extend-macro-environment1305 'current-module '()1306 (##sys#er-transformer1307 (lambda (x r c)1308 (##sys#check-syntax 'current-module x '(_))1309 (and-let* ((mod (##sys#current-module)))1310 `(##core#quote ,(##sys#module-name mod))))))13111312;; The chicken.module syntax environment1313(define ##sys#chicken.module-macro-environment (##sys#macro-environment))13141315(set! ##sys#scheme-macro-environment1316 (let ((me0 (##sys#macro-environment)))13171318(##sys#extend-macro-environment1319 'lambda1320 '()1321 (##sys#er-transformer1322 (lambda (x r c)1323 (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)))1324 `(##core#lambda ,@(cdr x)))))13251326(##sys#extend-macro-environment1327 'quote1328 '()1329 (##sys#er-transformer1330 (lambda (x r c)1331 (##sys#check-syntax 'quote x '(_ _))1332 `(##core#quote ,(cadr x)))))13331334(##sys#extend-macro-environment1335 'if1336 '()1337 (##sys#er-transformer1338 (lambda (x r c)1339 (##sys#check-syntax 'if x '(_ _ _ . #(_)))1340 `(##core#if ,@(cdr x)))))13411342(##sys#extend-macro-environment1343 'begin1344 '()1345 (##sys#er-transformer1346 (lambda (x r c)1347 (##sys#check-syntax 'begin x '(_ . #(_ 0)))1348 `(##core#begin ,@(cdr x)))))13491350(set! chicken.syntax#define-definition1351 (##sys#extend-macro-environment1352 'define1353 '()1354 (##sys#er-transformer1355 (lambda (x r c)1356 (##sys#check-syntax 'define x '(_ . #(_ 1)))1357 (let loop ((form x))1358 (let ((head (cadr form))1359 (body (cddr form)) )1360 (cond ((not (pair? head))1361 (##sys#check-syntax 'define form '(_ variable . #(_ 0 1)))1362 (let ((name (or (getp head '##core#macro-alias) head)))1363 (##sys#register-export name (##sys#current-module)))1364 (when (c (r 'define) head)1365 (chicken.syntax#defjam-error x))1366 `(##core#begin1367 (##core#ensure-toplevel-definition ,head)1368 (##core#set!1369 ,head1370 ,(if (pair? body) (car body) '(##core#undefined)))))1371 ((pair? (car head))1372 (##sys#check-syntax 'define form '(_ (_ . lambda-list) . #(_ 1)))1373 (loop (chicken.syntax#expand-curried-define head body '()))) ;XXX '() should be se1374 (else1375 (##sys#check-syntax 'define form '(_ (variable . lambda-list) . #(_ 1)))1376 (loop (list (car x) (car head) `(##core#lambda ,(cdr head) ,@body)))))))))))13771378(set! chicken.syntax#define-syntax-definition1379 (##sys#extend-macro-environment1380 'define-syntax1381 '()1382 (##sys#er-transformer1383 (lambda (form r c)1384 (##sys#check-syntax 'define-syntax form '(_ variable _))1385 (let ((head (cadr form))1386 (body (caddr form)))1387 (let ((name (or (getp head '##core#macro-alias) head)))1388 (##sys#register-export name (##sys#current-module)))1389 (when (c (r 'define-syntax) head)1390 (chicken.syntax#defjam-error form))1391 `(##core#define-syntax ,head ,body))))))13921393(##sys#extend-macro-environment1394 'let1395 '()1396 (##sys#er-transformer1397 (lambda (x r c)1398 (cond ((and (pair? (cdr x)) (symbol? (cadr x)))1399 (##sys#check-syntax 'let x '(_ variable #((variable _) 0) . #(_ 1)))1400 (check-for-multiple-bindings (caddr x) x "let"))1401 (else1402 (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)))1403 (check-for-multiple-bindings (cadr x) x "let")))1404 `(##core#let ,@(cdr x)))))14051406(##sys#extend-macro-environment1407 'letrec1408 '()1409 (##sys#er-transformer1410 (lambda (x r c)1411 (##sys#check-syntax 'letrec x '(_ #((variable _) 0) . #(_ 1)))1412 (check-for-multiple-bindings (cadr x) x "letrec")1413 `(##core#letrec ,@(cdr x)))))14141415(##sys#extend-macro-environment1416 'let-syntax1417 '()1418 (##sys#er-transformer1419 (lambda (x r c)1420 (##sys#check-syntax 'let-syntax x '(_ #((variable _) 0) . #(_ 1)))1421 (check-for-multiple-bindings (cadr x) x "let-syntax")1422 `(##core#let-syntax ,@(cdr x)))))14231424(##sys#extend-macro-environment1425 'letrec-syntax1426 '()1427 (##sys#er-transformer1428 (lambda (x r c)1429 (##sys#check-syntax 'letrec-syntax x '(_ #((variable _) 0) . #(_ 1)))1430 (check-for-multiple-bindings (cadr x) x "letrec-syntax")1431 `(##core#letrec-syntax ,@(cdr x)))))14321433(##sys#extend-macro-environment1434 'set!1435 '()1436 (##sys#er-transformer1437 (lambda (x r c)1438 (##sys#check-syntax 'set! x '(_ _ _))1439 (let ((dest (cadr x))1440 (val (caddr x)))1441 (cond ((pair? dest)1442 `((##sys#setter ,(car dest)) ,@(cdr dest) ,val))1443 (else `(##core#set! ,dest ,val)))))))14441445(##sys#extend-macro-environment1446 'and1447 '()1448 (##sys#er-transformer1449 (lambda (form r c)1450 (let ((body (cdr form)))1451 (if (null? body)1452 #t1453 (let ((rbody (cdr body))1454 (hbody (car body)) )1455 (if (null? rbody)1456 hbody1457 `(##core#if ,hbody (,(r 'and) ,@rbody) #f) ) ) ) ) ) ) )14581459(##sys#extend-macro-environment1460 'or1461 '()1462 (##sys#er-transformer1463 (lambda (form r c)1464 (let ((body (cdr form)))1465 (if (null? body)1466 #f1467 (let ((rbody (cdr body))1468 (hbody (car body)))1469 (if (null? rbody)1470 hbody1471 (let ((tmp (r 'tmp)))1472 `(##core#let ((,tmp ,hbody))1473 (##core#if ,tmp ,tmp (,(r 'or) ,@rbody)) ) ) ) ) ) ) ) ) )14741475(##sys#extend-macro-environment1476 'cond1477 '()1478 (##sys#er-transformer1479 (lambda (form r c)1480 (let ((body (cdr form))1481 (%=> (r '=>))1482 (%or (r 'or))1483 (%else (r 'else)))1484 (let expand ((clauses body) (else? #f))1485 (if (not (pair? clauses))1486 '(##core#undefined)1487 (let ((clause (car clauses))1488 (rclauses (cdr clauses)) )1489 (##sys#check-syntax 'cond clause '#(_ 1))1490 (cond (else?1491 (##sys#warn1492 (chicken.format#sprintf "clause following `~S' clause in `cond'" else?)1493 (strip-syntax clause))1494 (expand rclauses else?)1495 '(##core#begin))1496 ((or (c %else (car clause))1497 (eq? #t (car clause))1498 ;; Like "constant?" from support.scm1499 (number? (car clause))1500 (char? (car clause))1501 (string? (car clause))1502 (eof-object? (car clause))1503 ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?1504 (##core#inline "C_bwpp" (car clause))1505 #;(bwp-object? (car clause))1506 (blob? (car clause))1507 (vector? (car clause))1508 (##sys#srfi-4-vector? (car clause))1509 (and (pair? (car clause))1510 (c (r 'quote) (caar clause))))1511 (expand rclauses (strip-syntax (car clause)))1512 (cond ((and (fx= (length clause) 3)1513 (c %=> (cadr clause)))1514 `(,(caddr clause) ,(car clause)))1515 ((pair? (cdr clause))1516 `(##core#begin ,@(cdr clause)))1517 ((c %else (car clause))1518 `(##core#undefined))1519 (else (car clause))))1520 ((null? (cdr clause))1521 `(,%or ,(car clause) ,(expand rclauses #f)))1522 ((and (fx= (length clause) 3)1523 (c %=> (cadr clause)))1524 (let ((tmp (r 'tmp)))1525 `(##core#let ((,tmp ,(car clause)))1526 (##core#if ,tmp1527 (,(caddr clause) ,tmp)1528 ,(expand rclauses #f) ) ) ) )1529 ((and (fx= (length clause) 4)1530 (c %=> (caddr clause)))1531 (let ((tmp (r 'tmp)))1532 `(##sys#call-with-values1533 (##core#lambda () ,(car clause))1534 (##core#lambda1535 ,tmp1536 (if (##sys#apply ,(cadr clause) ,tmp)1537 (##sys#apply ,(cadddr clause) ,tmp)1538 ,(expand rclauses #f) ) ) ) ) )1539 (else `(##core#if ,(car clause)1540 (##core#begin ,@(cdr clause))1541 ,(expand rclauses #f) ) ) ) ) ) ) ) ) ) )15421543(##sys#extend-macro-environment1544 'case1545 '((eqv? . scheme#eqv?))1546 (##sys#er-transformer1547 (lambda (form r c)1548 (##sys#check-syntax 'case form '(_ _ . #(_ 0)))1549 (let ((exp (cadr form))1550 (body (cddr form)) )1551 (let ((tmp (r 'tmp))1552 (%or (r 'or))1553 (%=> (r '=>))1554 (%eqv? (r 'eqv?))1555 (%else (r 'else)))1556 `(let ((,tmp ,exp))1557 ,(let expand ((clauses body) (else? #f))1558 (if (not (pair? clauses))1559 '(##core#undefined)1560 (let ((clause (car clauses))1561 (rclauses (cdr clauses)) )1562 (##sys#check-syntax 'case clause '#(_ 1))1563 (cond (else?1564 (##sys#warn1565 "clause following `else' clause in `case'"1566 (strip-syntax clause))1567 (expand rclauses #t)1568 '(##core#begin))1569 ((c %else (car clause))1570 (expand rclauses #t)1571 (cond ((null? (cdr clause))1572 `(##core#undefined))1573 ((and (fx= (length clause) 3) ; (else => expr)1574 (c %=> (cadr clause)))1575 `(,(caddr clause) ,tmp))1576 (else1577 `(##core#begin ,@(cdr clause)))))1578 (else1579 `(##core#if (,%or ,@(##sys#map1580 (lambda (x) `(,%eqv? ,tmp ',x))1581 (car clause)))1582 ,(if (and (fx= (length clause) 3) ; ((...) => expr)1583 (c %=> (cadr clause)))1584 `(,(caddr clause) ,tmp)1585 `(##core#begin ,@(cdr clause)))1586 ,(expand rclauses #f) ) ) ) ) ) ) ) ) ) ) ) )15871588(##sys#extend-macro-environment1589 'let*1590 '()1591 (##sys#er-transformer1592 (lambda (form r c)1593 (##sys#check-syntax 'let* form '(_ #((variable _) 0) . #(_ 1)))1594 (let ((bindings (cadr form))1595 (body (cddr form)) )1596 (let expand ((bs bindings))1597 (if (eq? bs '())1598 `(##core#let () ,@body)1599 `(##core#let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) ) )16001601(##sys#extend-macro-environment1602 'do1603 '()1604 (##sys#er-transformer1605 (lambda (form r c)1606 (##sys#check-syntax 'do form '(_ #((variable _ . #(_)) 0) . #(_ 1)))1607 (let ((bindings (cadr form))1608 (test (caddr form))1609 (body (cdddr form))1610 (dovar (r 'doloop)))1611 `(##core#let1612 ,dovar1613 ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)1614 (##core#if ,(car test)1615 ,(let ((tbody (cdr test)))1616 (if (eq? tbody '())1617 '(##core#undefined)1618 `(##core#begin ,@tbody) ) )1619 (##core#begin1620 ,(if (eq? body '())1621 '(##core#undefined)1622 `(##core#let () ,@body) )1623 (##core#app1624 ,dovar ,@(##sys#map (lambda (b)1625 (if (eq? (cdr (cdr b)) '())1626 (car b)1627 (car (cdr (cdr b))) ) )1628 bindings) ) ) ) ) ) ) ) )16291630(##sys#extend-macro-environment1631 'quasiquote1632 '()1633 (##sys#er-transformer1634 (lambda (form r c)1635 (let ((%quasiquote (r 'quasiquote))1636 (%unquote (r 'unquote))1637 (%unquote-splicing (r 'unquote-splicing)))1638 (define (walk x n) (simplify (walk1 x n)))1639 (define (walk1 x n)1640 (cond ((vector? x)1641 `(##sys#list->vector ,(walk (vector->list x) n)) )1642 ((not (pair? x)) `(##core#quote ,x))1643 (else1644 (let ((head (car x))1645 (tail (cdr x)))1646 (cond ((c %unquote head)1647 (cond ((eq? n 0)1648 (##sys#check-syntax 'unquote x '(_ _))1649 (car tail))1650 (else (list '##sys#cons `(##core#quote ,%unquote)1651 (walk tail (fx- n 1)) ) )))1652 ((c %quasiquote head)1653 (list '##sys#cons `(##core#quote ,%quasiquote)1654 (walk tail (fx+ n 1)) ) )1655 ((and (pair? head) (c %unquote-splicing (car head)))1656 (cond ((eq? n 0)1657 (##sys#check-syntax 'unquote-splicing head '(_ _))1658 `(##sys#append ,(cadr head) ,(walk tail n)))1659 (else1660 `(##sys#cons1661 (##sys#cons (##core#quote ,%unquote-splicing)1662 ,(walk (cdr head) (fx- n 1)) )1663 ,(walk tail n)))))1664 (else1665 `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )1666 (define (simplify x)1667 (cond ((chicken.syntax#match-expression x '(##sys#cons a (##core#quote ())) '(a))1668 => (lambda (env) (simplify `(##sys#list ,(cdr (assq 'a env))))) )1669 ((chicken.syntax#match-expression x '(##sys#cons a (##sys#list . b)) '(a b))1670 => (lambda (env)1671 (let ((bxs (assq 'b env)))1672 (if (fx< (length bxs) 32)1673 (simplify `(##sys#list ,(cdr (assq 'a env))1674 ,@(cdr bxs) ) )1675 x) ) ) )1676 ((chicken.syntax#match-expression x '(##sys#append a (##core#quote ())) '(a))1677 => (lambda (env) (cdr (assq 'a env))) )1678 (else x) ) )1679 (##sys#check-syntax 'quasiquote form '(_ _))1680 (walk (cadr form) 0) ) ) ) )16811682(##sys#extend-macro-environment1683 'delay1684 '()1685 (##sys#er-transformer1686 (lambda (form r c)1687 (##sys#check-syntax 'delay form '(_ _))1688 `(,(r 'delay-force)1689 (##sys#make-promise1690 (##sys#call-with-values (##core#lambda () ,(cadr form)) ##sys#list))))))16911692;;; syntax-rules16931694(include "synrules.scm")16951696(macro-subset me0)))16971698;;; the base macro environment (the old "scheme", essentially)1699;;; TODO: Remove this17001701(define ##sys#default-macro-environment1702 (fixup-macro-environment (##sys#macro-environment)))17031704(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))17051706;; register features17071708(register-feature! 'srfi-0 'srfi-46 'srfi-61 'srfi-87)