1;;; 2;;; compile-1.scm - The compiler: Pass 1 3;;; 4;;; Copyright (c) 2004-2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34;;=============================================================== 35;; Pass 1 36;; 37;; Converts S-expr to IForm. Macros are expanded. Variable references 38;; are resolved and converted to either $lref or $gref. The constant 39;; variable references (defined by define-constant) are converted to 40;; its values at this stage. 41 42;; Common entry to handle procedure call 43;; proc is IForm. args is [Sexpr]. 44(define-inline (pass1/call program proc args cenv) 45 (cond 46 [(has-tag? proc $LAMBDA) ; immediate lambda 47 (expand-inlined-procedure program proc (imap (cut pass1 <> cenv) args))] 48 [(null? args) ($call program proc '())] ; fast path 49 [(> (length args) MAX_LITERAL_ARG_COUNT) 50 (errorf "Too many arguments in the call of `~,,,,40s...'" program)] 51 [else (let1 cenv (cenv-sans-name cenv) 52 ($call program proc (imap (cut pass1 <> cenv) args)))])) 53 54;; Check if the head of the list is a variable, and if so, lookup it. 55;; Note that we need to detect the case ((with-module foo bar) arg ...) 56;; NB: This isn't a proper fix, for we cannot deal with the situation 57;; like nested or aliased with-modules. The Right Thing is to run 58;; `pass1 for syntax' on (car PROGRAM) and check the result to see if 59;; we need to treat PROGRAM as a special form or an ordinary procedure. 60;; It would be a large change, so this is a compromise... 61(define-inline (pass1/lookup-head head cenv) 62 (or (and (identifier? head) 63 (cenv-lookup-syntax cenv head)) 64 (and (pair? head) 65 (module-qualified-variable? head cenv) 66 (let1 mod (ensure-module (cadr head) 'with-module #f) 67 (cenv-lookup-syntax (cenv-swap-module cenv mod) (caddr head)))))) 68 69;;-------------------------------------------------------------- 70;; pass1 :: Sexpr, Cenv -> IForm 71;; 72;; The Pass 1 entry point. 73;; This is one of the most frequently called routine. It is critical to 74;; make sure all internal functions are inlined, in case you 75;; change something. 76(define (pass1 program cenv) 77 78 ;; Handle a global call. PROGRAM's car is resolved to an identifier, ID. 79 ;; We know PROGRAM is a call to global procedure, macro, or syntax. 80 (define (pass1/global-call id) 81 (receive (gval type) (global-call-type id cenv) 82 (if gval 83 (case type 84 [(macro) (pass1 (call-macro-expander gval program cenv) cenv)] 85 [(syntax) (call-syntax-handler gval program cenv)] 86 [(inline) (or (pass1/expand-inliner program id gval cenv) 87 (pass1/call program ($gref id) (cdr program) cenv))]) 88 (pass1/call program ($gref id) (cdr program) cenv)))) 89 90 ;; main body of pass1 91 (cond 92 [(pair? program) ; (op . args) 93 (unless (list? program) 94 (error "proper list required for function application or macro use:" program)) 95 (cond 96 [(pass1/lookup-head (car program) cenv) 97 => (^h (cond 98 [(wrapped-identifier? h) (pass1/global-call h)] 99 [(lvar? h) (pass1/call program ($lref h) (cdr program) cenv)] 100 [(macro? h) ;; local macro 101 (pass1 (call-macro-expander h program cenv) cenv)] 102 [(syntax? h);; locally rebound syntax 103 (call-syntax-handler h program cenv)] 104 [else (error "[internal] unknown resolution of head:" h)]))] 105 [(pass1/detect-constant-setter-call (car program) cenv) 106 => (^[setter] 107 (or (pass1/expand-inliner program `(setter ,(car program)) 108 setter cenv) 109 (and-let* ([info (~ setter'info)] 110 [binfo (pair-attribute-get info 'bind-info #f)] 111 [mod (find-module (car binfo))] 112 [name (cadr binfo)]) 113 (pass1/call program 114 (pass1 (make-identifier name mod '()) cenv) 115 (cdr program) cenv)) 116 (pass1/call program (pass1 (car program) (cenv-sans-name cenv)) 117 (cdr program) cenv)))] 118 [else (pass1/call program (pass1 (car program) (cenv-sans-name cenv)) 119 (cdr program) cenv)])] 120 [(identifier? program) ; variable reference 121 (let1 r (cenv-lookup-variable cenv program) 122 (cond [(lvar? r) ($lref r)] 123 [(wrapped-identifier? r) 124 (or (and-let* ([const (find-const-binding r)]) ($const const)) 125 ($gref r))] 126 [else (error "[internal] cenv-lookup returned weird obj:" r)]))] 127 [else ($const program)])) 128 129;; If op is (setter <var>), check if <var> has inlinable binding and 130;; its setter is locked; if so, returns the setter. 131;; There are a bunch of hoops to go through to satisfy the condition. 132(define (pass1/detect-constant-setter-call op cenv) 133 (and (pair? op) (pair? (cdr op)) (null? (cddr op)) 134 (not (vm-compiler-flag-is-set? SCM_COMPILE_NOINLINE_SETTERS)) 135 (global-identifier=? (car op) setter.) 136 (and-let* ([var (cadr op)] 137 [ (identifier? var) ] ;ok, <var> is variable 138 [hd (pass1/lookup-head var cenv)] 139 [ (wrapped-identifier? hd) ] 140 [gloc (id->bound-gloc hd)] ; <var> has inlinable binding 141 [val (gloc-ref gloc)] 142 [ (procedure? val) ]) 143 (procedure-locked-setter val)))) ;and has locked setter 144 145;; Expand inlinable procedure. Returns Maybe IForm 146;; NAME is a variable, used for the error message. 147;; PROC is <procedure>. 148;; NB: This may return #f if inlining is abandoned. 149(define (pass1/expand-inliner src name proc cenv) 150 ;; TODO: for inline asm, check validity of opcode. 151 (let ([inliner (%procedure-inliner proc)] 152 [args (cdr src)]) 153 (match inliner 154 [#f #f] ;no inliner, fallback case 155 [(? integer?) ;VM insn 156 (let ([nargs (length args)] 157 [opt? (slot-ref proc 'optional)]) 158 (unless (argcount-ok? args (slot-ref proc 'required) opt?) 159 (errorf "wrong number of arguments: ~a requires ~a, but got ~a" 160 (if (identifier? name) (identifier->symbol name) name) 161 (slot-ref proc 'required) nargs)) 162 ;; We might get away with this limit by transforming inline calls 163 ;; to apply or something. Maybe in future. 164 (when (> nargs MAX_LITERAL_ARG_COUNT) 165 (errorf "Too many arguments in the call of `~,,,,40s...'" src)) 166 ($asm src (if opt? `(,inliner ,nargs) `(,inliner)) 167 (imap (cut pass1 <> cenv) args)))] 168 [(? vector?) ;inlinable lambda 169 (expand-inlined-procedure src 170 (unpack-iform inliner) 171 (imap (cut pass1 <> cenv) args))] 172 [(? macro?) 173 (let1 expanded (call-macro-expander inliner src cenv) 174 (if (eq? src expanded) ;no expansion 175 #f 176 (pass1 expanded cenv)))] 177 [(? procedure?) 178 ;; Call procedural inliner: Src, [IForm] -> IForm 179 ;; The second arg is IForms of arguments. 180 (let1 iform (inliner src (imap (cut pass1 <> cenv) args)) 181 (if (undefined? iform) ;no expansion 182 #f 183 iform))] 184 [_ (errorf "[internal] Invalid inliner attached to ~s: ~s" 185 proc inliner)] 186 ))) 187 188;; Returns #t iff exp is the form (with-module module VARIABLE) 189;; We need to check the global value of with-module, for it might 190;; be redefined. We assume this function is called infrequently, 191;; thus we can afford the time. 192(define (module-qualified-variable? expr cenv) 193 (match expr 194 [((? identifier? wm) mod (? identifier? v)) 195 (and-let* ([var (cenv-lookup-syntax cenv wm)] 196 [ (identifier? var) ]) 197 (global-identifier=? var with-module.))] 198 [_ #f])) 199 200;;-------------------------------------------------------------- 201;; pass1/body - Compiling body with internal definitions. 202;; 203;; For the letrec* semantics, we need to build the internal frame 204;; as we go though the body, since internal macro definition need to 205;; capture the internal environment. 206;; 207;; (let ((x 1)) 208;; (define x 2) 209;; (define-syntax foo 210;; (syntax-rules () 211;; [(_ v) (define v x)])) ;; must refer to inner x 212;; (foo y) 213;; y) => 2 214;; 215;; To avoid unnecessary allocation, we adopt somewhat convoluted strategy 216;; that delays frame allocation until needed, and once allocated, we 217;; "grow" the frame as new definition appears. This is an exception of 218;; the general principle that cenv is immutable. 219 220;; pass1/body :: [Sexpr], Cenv -> IForm 221(define (pass1/body exprs cenv) 222 ;; First, we pair up each expr with dummy source info '(). Some of expr 223 ;; may be an 'include' form and expanded into the content of the file, 224 ;; in which case we keep the source file info in each cdr of the pair. 225 (pass1/body-rec (map list exprs) #f #f cenv)) 226 227;; If we find internal (syntax) definition, we extend cenv with 228;; two frames, one for local macros and one for local variables, 229;; so that the internal macros can capture the correct scope of 230;; identifiers. 231;; For the local variables, we insert dummy binding 232;; (<name> :rec <init-expr> . <src>) 233;; as the placeholder. Once we find the boundary of definitions and 234;; expressions, we re-evaluate <init-expr> and replace the frame entry with 235;; (<name> . <lvar>) 236(define (pass1/body-rec exprs mframe vframe cenv) 237 (match exprs 238 [(((op . args) . src) . rest) 239 (or (and-let* ([ (or (not vframe) (not (assq op vframe))) ] 240 [head (pass1/lookup-head op cenv)]) 241 (unless (list? args) 242 (error "proper list required for function application \ 243 or macro use:" (caar exprs))) 244 (cond 245 [(lvar? head) (pass1/body-finish exprs mframe vframe cenv)] 246 [(macro? head) ; locally defined macro 247 (pass1/body-macro-expand-rec head exprs mframe vframe cenv)] 248 [(syntax? head) ; when (let-syntax ((xif if)) (xif ...)) etc. 249 (pass1/body-finish exprs mframe vframe cenv)] 250 [(and (pair? head) (eq? (car head) :rec)) 251 (pass1/body-finish exprs mframe vframe cenv)] 252 [(not (wrapped-identifier? head)) 253 (error "[internal] pass1/body" head)] 254 [(or (global-identifier=? head define.) 255 (global-identifier=? head define-inline.) 256 (global-identifier=? head r5rs-define.)) 257 (let1 def (match args 258 [((name . formals) . body) 259 `(,name :rec (,lambda. ,formals ,@body) . ,src)] 260 [(var init) `(,var :rec ,init . ,src)] 261 [(var) 262 (if (global-identifier=? head r5rs-define.) 263 (error "define without expression is not allowed in R7RS" (caar exprs)) 264 `(,var :rec ,(undefined) . ,src))] 265 [_ (error "malformed internal define:" (caar exprs))]) 266 (if (not mframe) 267 (let* ([cenv (cenv-extend cenv '() SYNTAX)] 268 [mframe (car (cenv-frames cenv))] 269 [cenv (cenv-extend cenv `(,def) LEXICAL)] 270 [vframe (car (cenv-frames cenv))]) 271 (pass1/body-rec rest mframe vframe cenv)) 272 (begin 273 (push! (cdr vframe) def) 274 (pass1/body-rec rest mframe vframe cenv))))] 275 [(global-identifier=? head define-syntax.) ; internal syntax definition 276 (match args 277 [(name trans-spec) 278 (if (not mframe) 279 (let* ([cenv (cenv-extend cenv `((,name)) SYNTAX)] 280 [mframe (car (cenv-frames cenv))] 281 [cenv (cenv-extend cenv `() LEXICAL)] 282 [vframe (car (cenv-frames cenv))] 283 [trans (pass1/eval-macro-rhs 284 'define-syntax trans-spec 285 (cenv-add-name cenv (variable-name name)))]) 286 (assq-set! (cdr mframe) name trans) 287 (pass1/body-rec rest mframe vframe cenv)) 288 (begin 289 (push! (cdr mframe) `(,name)) 290 (let1 trans (pass1/eval-macro-rhs 291 'define-syntax trans-spec 292 (cenv-add-name cenv (variable-name name))) 293 (assq-set! (cdr mframe) name trans) 294 (pass1/body-rec rest mframe vframe cenv))))] 295 [_ (error "syntax-error: malformed internal define-syntax:" 296 `(,op ,@args))])] 297 [(global-identifier=? head begin.) ;intersperse forms 298 (pass1/body-rec (append (imap (cut cons <> src) args) rest) 299 mframe vframe cenv)] 300 [(global-identifier=? head include.) 301 (let1 sexpr&srcs (pass1/expand-include args cenv #f) 302 (pass1/body-rec (append sexpr&srcs rest) mframe vframe cenv))] 303 [(global-identifier=? head include-ci.) 304 (let1 sexpr&srcs (pass1/expand-include args cenv #t) 305 (pass1/body-rec (append sexpr&srcs rest) mframe vframe cenv))] 306 [(wrapped-identifier? head) 307 (or (and-let* ([gloc (id->bound-gloc head)] 308 [gval (gloc-ref gloc)] 309 [ (macro? gval) ]) 310 (pass1/body-macro-expand-rec gval exprs mframe vframe cenv)) 311 (pass1/body-finish exprs mframe vframe cenv))] 312 [else (error "[internal] pass1/body" head)])) 313 (pass1/body-finish exprs mframe vframe cenv))] 314 [_ (pass1/body-finish exprs mframe vframe cenv)])) 315 316(define (pass1/body-macro-expand-rec mac exprs mframe vframe cenv) 317 (pass1/body-rec 318 (acons (call-macro-expander mac (caar exprs) cenv) 319 (cdar exprs) ;src 320 (cdr exprs)) ;rest 321 mframe vframe cenv)) 322 323;; Finishing internal definitions. If we have internal defs, we wrap 324;; the rest by letrec. 325(define (pass1/body-finish exprs mframe vframe cenv) 326 (if (not mframe) 327 (pass1/body-rest exprs cenv) 328 ;; Replace dummy bindings to the real one 329 (let* ([intdefs. (reverse (cdr vframe))] 330 [vars (map car intdefs.)] 331 [lvars (imap make-lvar+ vars)]) 332 (set-cdr! vframe (%map-cons vars lvars)) 333 ($let #f 'rec* lvars 334 (imap2 (cut pass1/body-init <> <> cenv) lvars (map cddr intdefs.)) 335 (pass1/body-rest exprs cenv))))) 336 337(define (pass1/body-init lvar init&src newenv) 338 (let1 e (if (null? (cdr init&src)) 339 (cenv-add-name newenv (lvar-name lvar)) 340 (cenv-add-name/source newenv (lvar-name lvar) (cdr init&src))) 341 (rlet1 iexpr (pass1 (car init&src) e) 342 (lvar-initval-set! lvar iexpr)))) 343 344(define (pass1/body-rest exprs cenv) 345 (match exprs 346 [() ($seq '())] 347 [(expr&src) (pass1/body-1 expr&src cenv)] 348 [_ (let1 stmtenv (cenv-sans-name cenv) 349 ($seq (let loop ([exprs exprs] [r '()]) 350 (if (null? (cdr exprs)) 351 (reverse (cons (pass1/body-1 (car exprs) cenv) r)) 352 (loop (cdr exprs) 353 (cons (pass1/body-1 (car exprs) stmtenv) r))))))])) 354 355(define (pass1/body-1 expr&src cenv) 356 (let1 src (cdr expr&src) 357 (if (string? src) 358 (pass1 (car expr&src) (cenv-swap-source cenv src)) 359 (pass1 (car expr&src) cenv)))) 360 361;;-------------------------------------------------------------- 362;; Pass1 utilities 363;; 364 365;; get symbol or id, and returns identiier. 366(define (ensure-identifier sym-or-id cenv) 367 (if (symbol? sym-or-id) 368 (make-identifier sym-or-id (cenv-module cenv) (cenv-frames cenv)) 369 sym-or-id)) 370 371;; Does the given argument list satisfy procedure's reqargs/optarg? 372(define (argcount-ok? args reqargs optarg?) 373 (let1 nargs (length args) 374 (or (and (not optarg?) (= nargs reqargs)) 375 (and optarg? (>= nargs reqargs))))) 376 377;; signal an error if the form is not on the toplevel 378(define-inline (check-toplevel form cenv) 379 (unless (cenv-toplevel? cenv) 380 (error "syntax-error: the form can appear only in the toplevel:" form))) 381 382;; returns a module specified by THING. 383(define (ensure-module thing name create?) 384 (let1 mod (cond [(identifier? thing) (find-module (identifier->symbol thing))] 385 [(module? thing) thing] 386 [else 387 (errorf "~a requires a module name or a module, but got: ~s" 388 name thing)]) 389 (or mod 390 (if create? 391 (make-module (identifier->symbol thing)) 392 (errorf "~a: no such module: ~s" name thing))))) 393 394;; IFORM must be a $LAMBDA node. This expands the application of IFORM 395;; on IARGS (list of IForm) into a mere $LET node. 396;; The nodes within IFORM will be reused in the resulting $LET structure, 397;; so be careful not to share substructures of IFORM accidentally. 398(define (expand-inlined-procedure src iform iargs) 399 (let ([lvars ($lambda-lvars iform)] 400 [args (adjust-arglist ($lambda-reqargs iform) ($lambda-optarg iform) 401 iargs ($lambda-name iform))]) 402 (for-each (^[lv a] (lvar-initval-set! lv a)) lvars args) 403 ($let src 'let lvars args ($lambda-body iform)))) 404 405;; Adjust argument list according to reqargs and optarg count. 406;; Used in procedure inlining and local call optimization. 407(define (adjust-arglist reqargs optarg iargs name) 408 (unless (argcount-ok? iargs reqargs (> optarg 0)) 409 (errorf "wrong number of arguments: ~a requires ~a, but got ~a" 410 name reqargs (length iargs))) 411 (if (zero? optarg) 412 iargs 413 (receive (reqs opts) (split-at iargs reqargs) 414 (append! reqs (list (if (null? opts) ($const '()) ($list #f opts))))))) 415 416;;---------------------------------------------------------------- 417;; Pass1 syntaxes 418;; 419 420(define-macro (define-pass1-syntax formals module . body) 421 (let ([mod (ecase module 422 [(:null) 'null] 423 [(:gauche) 'gauche] 424 [(:internal) 'gauche.internal])] 425 ;; a trick to assign comprehensive name to body: 426 [name (string->symbol #"syntax/~(car formals)")]) 427 `(let ((,name (^ ,(cdr formals) ,@body)) 428 (m (find-module ',mod))) 429 (%insert-syntax-binding m ',(car formals) 430 (make-syntax ',(car formals) m ,name))))) 431 432(define (global-id id) (make-identifier id (find-module 'gauche) '())) 433(define (global-id% id) (make-identifier id (find-module 'gauche.internal) '())) 434 435(define define. (global-id 'define)) 436(define define-inline. (global-id 'define-inline)) 437(define define-syntax. (global-id 'define-syntax)) 438(define lambda. (global-id 'lambda)) 439(define r5rs-define. (make-identifier 'define (find-module 'null) '())) 440(define r5rs-lambda. (make-identifier 'lambda (find-module 'null) '())) 441(define setter. (global-id 'setter)) 442(define lazy. (global-id 'lazy)) 443(define eager. (global-id 'eager)) 444(define values. (global-id 'values)) 445(define begin. (global-id 'begin)) 446(define let. (global-id 'let)) 447(define include. (global-id 'include)) 448(define include-ci. (global-id 'include-ci)) 449(define else. (global-id 'else)) 450(define =>. (global-id '=>)) 451(define current-module. (global-id 'current-module)) 452(define with-module. (global-id 'with-module)) 453(define quasiquote. (global-id 'quasiquote)) 454(define unquote. (global-id 'unquote)) 455(define unquote-splicing. (global-id 'unquote-splicing)) 456(define let-optionals*. (global-id 'let-optionals*)) 457(define let-keywords*. (global-id 'let-keywords*)) 458 459(define make-case-lambda. (global-id% 'make-case-lambda)) 460(define %make-er-transformer. (global-id% '%make-er-transformer)) 461(define %make-er-transformer/toplevel. (global-id% '%make-er-transformer/toplevel)) 462(define %with-inline-transformer. (global-id% '%with-inline-transformer)) 463 464;; Returns an IForm for (values) - useful for define-pass1-syntax that does 465;; compile-time things and returns nothing. The delay trick is to create 466;; iform only once. The module to call pass1 doesn't matter, for we directly 467;; use identifier for gauche#values. 468(define $values0 (let1 iform (delay (pass1 `(,values.) (make-bottom-cenv))) 469 (^[] (force iform)))) 470 471;; Definitions ........................................ 472 473;; Note on constant binding and inlinable binding: 474;; define-constant and define-inline both create a binding that 475;; is not supposed to be altered, but they have slightly different 476;; semantics. Define-constant binds a global variable to a value that 477;; is computable at compile time, and serializable to a precompiled 478;; file. When the compiler sees a global variable reference with 479;; a constant binding, it replaces the reference to the value itself 480;; at pass 1. Define-inline can bind a variable to a value that is 481;; calculated at runtime. The compiler does not replace the variable 482;; references with values, but it freely rearranges the references within 483;; the source code. If an inlinable binding is used at the head position, 484;; the compiler looks at its value, and if it is known to be bound to 485;; an inlinable procedure, the procedure's body is inlined. 486 487(define-pass1-syntax (define form cenv) :null 488 (pass1/define form form '() #f (cenv-module cenv) cenv)) 489 490(define-pass1-syntax (define form cenv) :gauche 491 (pass1/define form form '() #t (cenv-module cenv) cenv)) 492 493(define-pass1-syntax (define-constant form cenv) :gauche 494 (pass1/define form form '(const) #t (cenv-module cenv) cenv)) 495 496(define-pass1-syntax (define-in-module form cenv) :gauche 497 (match form 498 [(_ module . rest) 499 (pass1/define `(_ . ,rest) form '() #t 500 (ensure-module module 'define-in-module #f) 501 cenv)] 502 [_ (error "syntax-error: malformed define-in-module:" form)])) 503 504(define (pass1/define form oform flags extended? module cenv) 505 (check-toplevel oform cenv) 506 (match form 507 [(_ (name . args) body ...) 508 (pass1/define `(define ,name 509 ,(with-original-source 510 `(,(if extended? lambda. r5rs-lambda.) ,args ,@body) 511 oform)) 512 oform flags extended? module cenv)] 513 514 [(_ name) 515 (if extended? 516 ;; Gauche's define allows R6RS-style (define <name>). 517 (pass1/define `(define ,name ,(undefined)) 518 oform flags #t module cenv) 519 ;; R7RS define doesn't allow it. 520 (error "define without an expression is not allowed in R7RS (it is in R6RS):" oform))] 521 [(_ name expr) 522 (unless (identifier? name) (error "syntax-error:" oform)) 523 (let1 cenv (cenv-add-name cenv (variable-name name)) 524 ;; Hygiene alert 525 ;; If NAME is an identifier, it is inserted by macro expander; we 526 ;; can't simply place it in $define, since it would insert a toplevel 527 ;; definition into the toplevel of macro-definition environment--- 528 ;; we don't want a mere macro call would modify different module. 529 ;; We rename it to uninterned symbol, so, even the binding itself 530 ;; is into the macro-definiting module, it won't be visible from 531 ;; other code except the code generated in the same macro expansion. 532 ;; A trick - we directly modify the identifier, so that other forms 533 ;; referring to the same (eq?) identifier can keep referring it. 534 (let1 id (if (wrapped-identifier? name) 535 (%rename-toplevel-identifier! name) 536 (make-identifier name module '())) 537 ;; Insert dummy binding at compile time, if we don't have one yet. 538 ;; This matters when we compile multiple modules at once, and 539 ;; one need to import from another with qualifiers. 540 (unless (vm-compiler-flag-is-set? SCM_COMPILE_LEGACY_DEFINE) 541 (%insert-binding module (unwrap-syntax name) 542 (%uninitialized) '(fresh))) 543 ($define oform flags id (pass1 expr cenv))))] 544 [_ (error "syntax-error:" oform)])) 545 546(define (%rename-toplevel-identifier! identifier) 547 (slot-set! identifier 'name (gensym #"~(identifier->symbol identifier).")) 548 identifier) 549 550;; Inlinable procedure. 551;; Inlinable procedure has both properties of a macro and a procedure. 552;; It is a bit tricky since the inliner information has to exist 553;; both in compile time and execution time. 554;; 555;; Processing define-inline involves two actions. 556;; (1) Process the lambda node to be inlined. A packed IForm should be 557;; attached, and if the lambda node closes environment, some code 558;; transformation is required. 559;; (2) Bind the resulting node to the global name, and mark the binding 560;; 'inlinable'. 561;; 562;; These two are functionally orthogonal. Especially, not all expressions 563;; can yield inlinable lambda node as (1). However, to make procedure 564;; inlining work effectively, both of these actions are required; that's 565;; why we process them together. 566;; 567;; Steps: 568;; 1. Canonicalize the form to (define-inline NAME EXPR). 569;; 2. See if EXPR ultimately returns $LAMBDA node. If so, does the 570;; node closes local environment? (pass1/check-inlinable-lambda) 571;; 3. If EXPR does not yield a closure, we just create 'inlinable' 572;; binding (by pass1/make-inlinable-binding) 573;; but do not do anything further. 574;; 4. If EXPR directly yields a closure without an environment, 575;; process the closure (pass1/mark-closure-inlinable!) and 576;; then make inlinable binding. 577;; 5. If EXPR creates a local environment, we have to transform 578;; the closed variables into global variables. See the comment 579;; of subst-lvars above for the details of transformation. 580;; 581 582(define-pass1-syntax (define-inline form cenv) :gauche 583 (check-toplevel form cenv) 584 (match form 585 [(_ (name . args) . body) 586 (pass1/define-inline form name `(,lambda. ,args ,@body) cenv)] 587 [(_ name expr) 588 (unless (identifier? name) (error "syntax-error:" form)) 589 (pass1/define-inline form name expr cenv)] 590 [_ (error "syntax-error: malformed define-inline:" form)])) 591 592(define (pass1/define-inline form name expr cenv) 593 (let1 iform (pass1 expr (cenv-add-name cenv (variable-name name))) 594 (receive (closure closed) (pass1/check-inlinable-lambda iform) 595 (cond 596 [(and (not closure) (not closed)) ; too complex to inline 597 (pass1/make-inlinable-binding form name iform cenv)] 598 [(null? closed) ; no closed env 599 (pass1/mark-closure-inlinable! closure name cenv) 600 (pass1/make-inlinable-binding form name closure cenv)] 601 [else ; inlinable lambda has closed env. 602 ;; See the comment in subst-lvars above on the transformation. 603 ;; closed :: [(lvar . init-iform)] 604 ;; gvars :: [(identifier . iform)] 605 ;; subs :: [(lvar . iform)] ; iform being $const or $gref 606 (receive (gvars subs) 607 (pass1/define-inline-classify-env name closed cenv) 608 (let1 defs (pass1/define-inline-gen-closed-env gvars cenv) 609 ($lambda-body-set! closure 610 (subst-lvars ($lambda-body closure) subs)) 611 (pass1/mark-closure-inlinable! closure name cenv) 612 ($seq `(,@defs 613 ,(pass1/make-inlinable-binding form name closure cenv)))))] 614 )))) 615 616;; If IFORM generates a closure with local environment, returns 617;; the closure itself ($lambda node) and the environment 618;; ((lvar . init) ...). 619;; Typical case is ($let ... ($lambda ...)). In such case this 620;; procedure effectively strips $let nodes. 621;; If IFORM has more complicated structure, we just return (values #f #f) 622;; to give up inlining. 623(define (pass1/check-inlinable-lambda iform) 624 (cond [(has-tag? iform $LAMBDA) (values iform '())] 625 [(has-tag? iform $LET) 626 (receive (closure closed) 627 (pass1/check-inlinable-lambda ($let-body iform)) 628 (if (and (not closure) (not closed)) 629 (values #f #f) ; giveup 630 (let loop ([lvars (reverse ($let-lvars iform))] 631 [inits (reverse ($let-inits iform))] 632 [closed closed]) 633 (if (null? lvars) 634 (values closure closed) 635 (loop (cdr lvars) (cdr inits) 636 (acons (car lvars) (car inits) closed))))))] 637 [else (values #f #f)])) 638 639(define (pass1/define-inline-classify-env name lv&inits cenv) 640 (define gvars '()) 641 (define subs '()) 642 (let loop ([lv&inits lv&inits]) 643 (match lv&inits 644 [() (values (reverse gvars) (reverse subs))] 645 [((and (lv . (? $const?)) p) . lv&inits) 646 (push! subs p) (loop lv&inits)] 647 [((lv . init) . lv&inits) 648 (let1 gvar (make-identifier (gensym #"~|name|$~(lvar-name lv).") 649 (cenv-module cenv) '()) 650 (push! subs `(,lv . ,($gref gvar))) 651 (push! gvars `(,gvar . ,(subst-lvars init subs))) 652 (loop lv&inits))]))) 653 654;; gvars :: [(identifier . iform)] 655(define (pass1/define-inline-gen-closed-env gvars cenv) 656 (imap (^[gv] ($define #f '(inlinable) (car gv) (cdr gv))) gvars)) 657 658;; set up $LAMBDA node (closure) to be inlinable. If NAME is given, 659;; this also inserts the binding to the current compiling environment 660;; so that inlining is effective for the rest of the compilation. 661(define (pass1/mark-closure-inlinable! closure name cenv) 662 (let* ([module (cenv-module cenv)] 663 ;; Dummy-proc is only a placeholder to record the inliner info 664 ;; to be used during compilation of the current compiler unit. 665 ;; Its body doesn't matter, but we need to make sure every dummy-proc 666 ;; is a different instance. If we make it a constant procedure, 667 ;; Gauche's compiler optimizes it to refer to the singleton instance. 668 [dummy-proc (^ _ name)] 669 [packed (pack-iform closure)]) 670 ($lambda-flag-set! closure packed) 671 (when name 672 ;; record inliner function for compiler. this is used only when 673 ;; the procedure needs to be inlined in the same compiler unit. 674 (%insert-binding module (unwrap-syntax name) dummy-proc) 675 (set! (%procedure-inliner dummy-proc) (pass1/inliner-procedure packed))))) 676 677(define (pass1/make-inlinable-binding form name iform cenv) 678 ;; See the comment in pass1/define about renaming the toplevel identifier. 679 (let1 id (if (wrapped-identifier? name) 680 (%rename-toplevel-identifier! name) 681 (make-identifier name (cenv-module cenv) '())) 682 ($define form '(inlinable) id iform))) 683 684(define (pass1/inliner-procedure inline-info) 685 (unless (vector? inline-info) 686 (error "[internal] pass1/inliner-procedure got invalid info" inline-info)) 687 (^[form cenv] 688 (expand-inlined-procedure form (unpack-iform inline-info) 689 (imap (cut pass1 <> cenv) (cdr form))))) 690 691;; Toplevel macro definitions 692 693(define-pass1-syntax (define-macro form cenv) :gauche 694 (check-toplevel form cenv) 695 (match form 696 [(_ (name . formals) body ...) 697 (pass1/define-macro form name `(,lambda. ,formals ,@body) cenv)] 698 [(_ name expr) 699 (pass1/define-macro form name expr cenv)] 700 [_ (error "syntax-error:" form)])) 701 702(define (pass1/define-macro src name expr cenv) 703 (unless (identifier? name) (error "syntax-error:" src)) 704 ;; TODO: macro autoload 705 (let* ([proc (eval expr (cenv-module cenv))] 706 [trans (%make-macro-transformer name 707 (^[form env] (apply proc (cdr form))) 708 expr #f)] 709 ;; See the "Hygiene alert" in pass1/define. 710 [id (if (wrapped-identifier? name) 711 (%rename-toplevel-identifier! name) 712 (make-identifier name (cenv-module cenv) '()))]) 713 (%insert-syntax-binding (identifier-module id) 714 (unwrap-syntax name) 715 trans) 716 ($const-undef))) 717 718(define-pass1-syntax (define-syntax form cenv) :null 719 (check-toplevel form cenv) 720 ;; Temporary: we use the old compiler's syntax-rules implementation 721 ;; for the time being. 722 (match form 723 [(_ name expr) 724 (let* ([cenv (cenv-add-name cenv (variable-name name))] 725 [trans (pass1/eval-macro-rhs 'define-syntax expr cenv)] 726 ;; See the "Hygiene alert" in pass1/define. 727 [id (if (wrapped-identifier? name) 728 (%rename-toplevel-identifier! name) 729 (make-identifier name (cenv-module cenv) '()))]) 730 (%insert-syntax-binding (identifier-module id) 731 (unwrap-syntax name) 732 trans) 733 ($const-undef))] 734 [_ (error "syntax-error: malformed define-syntax:" form)])) 735 736;; Experimental 737(define-pass1-syntax (define-hybrid-syntax form cenv) :gauche 738 (pass1-define-hybrid-syntax form cenv)) 739(define-pass1-syntax (define-inline/syntax form cenv) :gauche ;deprecated 740 (pass1-define-hybrid-syntax form cenv)) 741 742(define (pass1-define-hybrid-syntax form cenv) 743 (check-toplevel form cenv) 744 (match form 745 [(_ name expr macro-expr) 746 (let* ([cenv (cenv-add-name cenv (variable-name name))] 747 [xformer (pass1/eval-macro-rhs 'define-hybrid-syntax 748 macro-expr cenv)] 749 [body (pass1/call expr ($gref %with-inline-transformer.) 750 (list expr xformer) cenv)]) 751 (pass1/make-inlinable-binding form name body cenv))] 752 [_ (error "syntax-error: define-hybrid-syntax")])) 753 754;; Returns either <syntax> or <macro> 755(define (pass1/eval-macro-rhs who expr cenv) 756 (rlet1 transformer ((make-toplevel-closure (compile expr cenv))) 757 (unless (or (is-a? transformer <syntax>) 758 (is-a? transformer <macro>)) 759 (errorf "syntax-error: rhs expression of ~a ~s \ 760 doesn't yield a syntactic transformer: ~s" 761 who expr transformer)))) 762 763(inline-stub 764 (define-cproc make-toplevel-closure (code::<compiled-code>) 765 (return (Scm_MakeClosure (SCM_OBJ code) NULL))) 766 ) 767 768;; Macros ........................................... 769 770(define-pass1-syntax (er-macro-transformer form cenv) :gauche 771 (match form 772 [(_ xformer) 773 ;; We need to capture the current CENV as the macro definition 774 ;; environment. There's a catch, though---if we're AOT compiling 775 ;; a macro, the captured CENV must be serializable to a file, 776 ;; which isn't generally the case. 777 ;; So, if we're compiling toplevel, we call a special API that takes 778 ;; the current module and cenv-exp-name, and reconstruct the cenv 779 ;; at runtime. 780 ;; If cenv has local environment, we don't bother that, for the macro 781 ;; will be fully expanded during AOT compilation. HOWEVER - we can't 782 ;; embed cenv as a vector literal (e.g. `',cenv) since quoting will 783 ;; strip all identifier information in cenv. The right thing would be 784 ;; to make cenv as a record. For now, we take advantage that unquoted 785 ;; vector evaluates to itself, and insert cenv without quoting. This 786 ;; has to change if we prohibit unquoted vector literals. 787 (if (cenv-toplevel? cenv) 788 (pass1 `(,%make-er-transformer/toplevel. ,xformer 789 ,(cenv-module cenv) 790 ',(cenv-exp-name cenv)) 791 cenv) 792 (pass1 `(,%make-er-transformer. ,xformer ,cenv #f) cenv))] 793 [_ (error "syntax-error: malformed er-macro-transformer:" form)])) 794 795(define-pass1-syntax (eri-macro-transformer form cenv) :gauche 796 (match form 797 [(_ xformer) 798 ;; See the comment above in er-macro-transformer 799 (if (cenv-toplevel? cenv) 800 (pass1 `(,%make-er-transformer/toplevel. ,xformer 801 ,(cenv-module cenv) 802 ',(cenv-exp-name cenv) 803 #t) 804 cenv) 805 (pass1 `(,%make-er-transformer. ,xformer ,cenv #t) cenv))] 806 [_ (error "syntax-error: malformed eri-macro-transformer:" form)])) 807 808(define-pass1-syntax (%macroexpand form cenv) :gauche 809 (match form 810 [(_ expr) ($const (%internal-macro-expand expr cenv #f))] 811 [_ (error "syntax-error: malformed %macroexpand:" form)])) 812 813(define-pass1-syntax (%macroexpand-1 form cenv) :gauche 814 (match form 815 [(_ expr) ($const (%internal-macro-expand expr cenv #t))] 816 [_ (error "syntax-error: malformed %macroexpand-1:" form)])) 817 818(define (%internal-macro-expand expr cenv once?) 819 (define (xpand expr) 820 (match expr 821 [((? identifier? op) . args) 822 (let1 var (cenv-lookup-syntax cenv op) 823 (cond [(macro? var) (call-macro-expander var expr cenv)] 824 [(wrapped-identifier? var) 825 (if-let1 gval (and-let* ([gloc (id->bound-gloc var)] 826 [gval (gloc-ref gloc)] 827 [ (macro? gval) ]) 828 gval) 829 (call-macro-expander gval expr cenv) 830 expr)] 831 [else expr]))] 832 [((? macro? op) . args) (call-macro-expander op expr cenv)] 833 [_ expr])) 834 (if once? 835 (xpand expr) 836 (let loop ([expr expr]) 837 (let1 e2 (xpand expr) 838 (if (eq? e2 expr) 839 expr 840 (loop e2)))))) 841 842(define-pass1-syntax (... form cenv) :null 843 (error "invalid syntax:" form)) 844 845(define-pass1-syntax (let-syntax form cenv) :null 846 (match form 847 [(_ ((name trans-spec) ...) body ...) 848 (let* ([trans (map (^[n x] (pass1/eval-macro-rhs 849 'let-syntax x 850 (cenv-add-name cenv (variable-name n)))) 851 name trans-spec)] 852 [newenv (cenv-extend cenv (%map-cons name trans) SYNTAX)]) 853 (pass1/body body newenv))] 854 [_ (error "syntax-error: malformed let-syntax:" form)])) 855 856(define-pass1-syntax (letrec-syntax form cenv) :null 857 (match form 858 [(_ ((name trans-spec) ...) body ...) 859 (let* ([newenv (cenv-extend cenv (%map-cons name trans-spec) SYNTAX)] 860 [trans (map (^[n x] (pass1/eval-macro-rhs 861 'letrec-syntax x 862 (cenv-add-name newenv (variable-name n)))) 863 name trans-spec)]) 864 (for-each set-cdr! (cdar (cenv-frames newenv)) trans) 865 (pass1/body body newenv))] 866 [_ (error "syntax-error: malformed letrec-syntax:" form)])) 867 868(define-pass1-syntax (syntax-rules form cenv) :null 869 (match form 870 [(_ (literal ...) rule ...) 871 ($const (compile-syntax-rules (cenv-exp-name cenv) form #t literal rule 872 (cenv-module cenv) 873 (cenv-frames cenv)))] 874 [(_ (? variable-or-keyword? elli) (literal ...) rule ...) 875 ;; NB: We allow keyword for ellipsis, so that something like ::: can be 876 ;; used. 877 ($const (compile-syntax-rules (cenv-exp-name cenv) form elli literal rule 878 (cenv-module cenv) 879 (cenv-frames cenv)))] 880 [_ (error "syntax-error: malformed syntax-rules:" form)])) 881 882;; If family ........................................ 883 884(define-pass1-syntax (if form cenv) :null 885 (match form 886 [(_ test then else) 887 ($if form (pass1 test (cenv-sans-name cenv)) 888 (pass1 then cenv) (pass1 else cenv))] 889 [(_ test then) 890 ($if form (pass1 test (cenv-sans-name cenv)) 891 (pass1 then cenv) ($const-undef))] 892 [_ (error "syntax-error: malformed if:" form)])) 893 894(define-pass1-syntax (and form cenv) :null 895 (define (rec exprs) 896 (match exprs 897 [() `#(,$CONST #t)] 898 [(expr) (pass1 expr cenv)] 899 [(expr . more) 900 ($if #f (pass1 expr (cenv-sans-name cenv)) (rec more) ($it))] 901 [_ (error "syntax-error: malformed and:" form)])) 902 (rec (cdr form))) 903 904(define-pass1-syntax (or form cenv) :null 905 (define (rec exprs) 906 (match exprs 907 [() ($const-f)] 908 [(expr) (pass1 expr cenv)] 909 [(expr . more) 910 ($if #f (pass1 expr (cenv-sans-name cenv)) ($it) (rec more))] 911 [_ (error "syntax-error: malformed or:" form)])) 912 (rec (cdr form))) 913 914(define-pass1-syntax (when form cenv) :gauche 915 (match form 916 [(_ test expr1 expr2 ...) 917 (let1 cenv (cenv-sans-name cenv) 918 ($if form (pass1 test cenv) 919 ($seq (imap (cut pass1 <> cenv) (cons expr1 expr2))) 920 ($const-undef)))] 921 [_ (error "syntax-error: malformed when:" form)])) 922 923(define-pass1-syntax (unless form cenv) :gauche 924 (match form 925 [(_ test expr1 expr2 ...) 926 (let1 cenv (cenv-sans-name cenv) 927 ($if form (pass1 test cenv) 928 ($const-undef) 929 ($seq (imap (cut pass1 <> cenv) (cons expr1 expr2)))))] 930 [_ (error "syntax-error: malformed unless:" form)])) 931 932(define-pass1-syntax (else form cenv) :null 933 (error "invalid syntax:" form)) 934(define-pass1-syntax (=> form cenv) :null 935 (error "invalid syntax:" form)) 936 937(define-pass1-syntax (cond form cenv) :null 938 (define (process-clauses cls) 939 (match cls 940 [() ($const-undef)] 941 ;; (else . exprs) 942 [(([? (cut global-eq? <> else. cenv)] exprs ...) . rest) 943 (unless (null? rest) 944 (error "syntax-error: 'else' clause followed by more clauses:" form)) 945 ($seq (imap (cut pass1 <> cenv) exprs))] 946 ;; (test => proc) 947 [((test [? (cut global-eq? <> =>. cenv)] proc) . rest) 948 (let ([test (pass1 test cenv)] 949 [tmp (make-lvar 'tmp)]) 950 (lvar-initval-set! tmp test) 951 ($let (car cls) 'let 952 (list tmp) 953 (list test) 954 ($if (car cls) 955 ($lref tmp) 956 ($call (car cls) 957 (pass1 proc (cenv-sans-name cenv)) 958 (list ($lref tmp))) 959 (process-clauses rest))))] 960 ;; (generator guard => proc) -- SRFI-61 'general cond clause' 961 [((generator guard [? (cut global-eq? <> =>. cenv)] receiver) . rest) 962 (let1 tmp (make-lvar 'tmp) 963 ($receive (car cls) 0 1 (list tmp) 964 (pass1 generator cenv) 965 ($if (car cls) 966 ($asm #f 967 `(,APPLY 2) 968 (list (pass1 guard (cenv-sans-name cenv)) 969 ($lref tmp))) 970 ($asm #f 971 `(,APPLY 2) 972 (list (pass1 receiver (cenv-sans-name cenv)) 973 ($lref tmp))) 974 (process-clauses rest))))] 975 [((test) . rest) ; (test) 976 ($if (car cls) (pass1 test (cenv-sans-name cenv)) 977 ($it) 978 (process-clauses rest))] 979 [((test exprs ...) . rest) ; (test . exprs) 980 ($if (car cls) (pass1 test (cenv-sans-name cenv)) 981 ($seq (imap (cut pass1 <> cenv) exprs)) 982 (process-clauses rest))] 983 [_ (error "syntax-error: bad clause in cond:" form)])) 984 985 (match form 986 [(_) (error "syntax-error: at least one clause is required for cond:" form)] 987 [(_ clause ...) (process-clauses clause)] 988 [else (error "syntax-error: malformed cond:" form)])) 989 990(define-pass1-syntax (case form cenv) :null 991 (define (process-clauses tmpvar cls) 992 (match cls 993 [() ($const-undef)] 994 [(([? (cut global-eq? <> else. cenv)] exprs ...) . rest) 995 (unless (null? rest) 996 (error "syntax-error: 'else' clause followed by more clauses:" form)) 997 (match exprs 998 ;; (else => proc) -- SRFI-87 case clause 999 [((? (cut global-eq? <> =>. cenv)) proc) 1000 ($call (car cls) 1001 (pass1 proc (cenv-sans-name cenv)) 1002 (list ($lref tmpvar)))] 1003 ;; (else . exprs) 1004 [_ ($seq (imap (cut pass1 <> cenv) exprs))])] 1005 [((elts exprs ...) . rest) 1006 (let ([nelts (length elts)] 1007 [elts (map unwrap-syntax elts)]) 1008 ($if (car cls) 1009 (case nelts 1010 [(0) ($const-f)] 1011 [(1) (if (symbol? (car elts)) 1012 ($eq? #f ($lref tmpvar) ($const (car elts))) 1013 ($eqv? #f ($lref tmpvar) ($const (car elts))))] 1014 [else ($memv #f ($lref tmpvar) ($const elts))]) 1015 (match exprs 1016 ;; (elts => proc) -- SRFI-87 case clause 1017 [((? (cut global-eq? <> =>. cenv)) proc) 1018 ($call (car cls) 1019 (pass1 proc (cenv-sans-name cenv)) 1020 (list ($lref tmpvar)))] 1021 ;; (elts . exprs) 1022 [_ ($seq (imap (cut pass1 <> cenv) exprs))]) 1023 (process-clauses tmpvar (cdr cls))))] 1024 [_ (error "syntax-error: bad clause in case:" form)])) 1025 1026 (match form 1027 [(_) 1028 (error "syntax-error: at least one clause is required for case:" form)] 1029 [(_ expr clause ...) 1030 (let* ([etree (pass1 expr cenv)] 1031 [tmp (make-lvar 'tmp)]) 1032 (lvar-initval-set! tmp etree) 1033 ($let form 'let 1034 (list tmp) 1035 (list etree) 1036 (process-clauses tmp clause)))] 1037 [_ (error "syntax-error: malformed case:" form)])) 1038 1039(define-pass1-syntax (and-let* form cenv) :gauche 1040 (define (process-binds binds body cenv) 1041 (match binds 1042 [() (pass1/body body cenv)] 1043 [((exp) . more) 1044 (if (and (null? more) (null? body)) 1045 (pass1 exp (cenv-sans-name cenv)) 1046 ($if form (pass1 exp (cenv-sans-name cenv)) 1047 (process-binds more body cenv) 1048 ($it)))] 1049 [([? identifier? var] . more) 1050 (if (and (null? more) (null? body)) 1051 (pass1 var (cenv-sans-name cenv)) 1052 ($if form (pass1 var (cenv-sans-name cenv)) 1053 (process-binds more body cenv) 1054 ($it)))] 1055 [(([? identifier? var] init) . more) 1056 (if (and (null? more) (null? body)) 1057 (pass1 init (cenv-add-name cenv var)) 1058 (let* ([lvar (make-lvar var)] 1059 [newenv (cenv-extend cenv `((,var . ,lvar)) LEXICAL)] 1060 [itree (pass1 init (cenv-add-name cenv var))]) 1061 (lvar-initval-set! lvar itree) 1062 ($let form 'let 1063 (list lvar) 1064 (list itree) 1065 ($if form ($lref lvar) 1066 (process-binds more body newenv) 1067 ($it)))))] 1068 [_ (error "syntax-error: malformed and-let*:" form)])) 1069 1070 (match form 1071 [(_ ()) ($const #t)] ;special base case 1072 [(_ binds . body) (process-binds binds body cenv)] 1073 [_ (error "syntax-error: malformed and-let*:" form)])) 1074 1075;; Quote and quasiquote ................................ 1076 1077(define (pass1/quote obj) 1078 ($const ($ unwrap-syntax obj 1079 $ not $ vm-compiler-flag-is-set? SCM_COMPILE_MUTABLE_LITERALS))) 1080 1081(define-pass1-syntax (quote form cenv) :null 1082 (match form 1083 [(_ obj) (pass1/quote obj)] 1084 [else (error "syntax-error: malformed quote:" form)])) 1085 1086(define-pass1-syntax (quasiquote form cenv) :null 1087 (match form 1088 [(_ obj) (quasi-expand obj cenv)] 1089 [_ (error "syntax-error: malformed quasiquote:" form)])) 1090 1091(define-pass1-syntax (unquote form cenv) :null 1092 (error "unquote appeared outside quasiquote:" form)) 1093 1094(define-pass1-syntax (unquote-splicing form cenv) :null 1095 (error "unquote-splicing appeared outside quasiquote:" form)) 1096 1097;; We need these to be bound so that scheme.base can export them 1098;; as specified in R7RS. 1099(define-pass1-syntax (_ form cenv) :null 1100 ($const-undef)) 1101 1102(define-pass1-syntax (... form cenv) :null 1103 ($const-undef)) 1104 1105;; quasiquote expander 1106 1107(define (quasi-expand obj cenv) 1108 ;; We want to avoid unnecessary allocation as much as possible. 1109 ;; Current code generates constants not only the obvious constant 1110 ;; case, e.g. `(a b c), but also folds constant variable references, 1111 ;; e.g. (define-constant x 3) then `(,x) generate a constant list '(3). 1112 ;; This extends as far as the pass-1 constant folding goes, so `(,(+ x 1)) 1113 ;; also becomes '(4). 1114 ;; NB: The current code allocates lots of intermediate $const node. 1115 (define (quasiquote? v) (global-eq? v quasiquote. cenv)) 1116 (define (unquote? v) (global-eq? v unquote. cenv)) 1117 (define (unquote-splicing? v) (global-eq? v unquote-splicing. cenv)) 1118 (define (unquote*? v) (or (unquote? v) (unquote-splicing? v))) 1119 1120 ;; In the context where there's no outer list to which we intersperse to. 1121 (define (quasi obj level) 1122 (match obj 1123 [((? quasiquote?) x) 1124 (let1 xx (quasi x (+ level 1)) 1125 (if ($const? xx) 1126 ($const (list 'quasiquote ($const-value xx))) 1127 ($list obj (list ($const 'quasiquote) xx))))] 1128 [((? unquote?) x) 1129 (if (zero? level) 1130 (pass1 x cenv) 1131 (let1 xx (quasi x (- level 1)) 1132 (if ($const? xx) 1133 ($const (list 'unquote ($const-value xx))) 1134 ($list obj (list ($const 'unquote) xx)))))] 1135 [((? unquote*? op) . xs) ;valid unquote is already handled 1136 (if (zero? level) 1137 (errorf "invalid ~a form in this context: ~s" op obj) 1138 (let1 xx (quasi* xs (- level 1)) 1139 (if ($const? xx) 1140 ($const (cons op ($const-value xx))) 1141 ($cons obj ($const op) xx))))] 1142 [(? pair?) (quasi* obj level)] 1143 [(? vector?) (quasi-vector obj level)] 1144 [(? wrapped-identifier?) ($const (unwrap-syntax obj))] 1145 [() ($const-nil)] 1146 [_ ($const obj)])) 1147 1148 ;; In the spliceable context. objs is always a list. 1149 (define (quasi* objs level) 1150 ;; NB: we already excluded toplevel quasiquote and unquote 1151 (match objs 1152 [(((? unquote*? op) . xs) . ys) 1153 (let1 yy (quasi* ys level) 1154 (if (zero? level) 1155 ((if (unquote? op) build build@) 1156 (imap (cut pass1 <> cenv) xs) yy) 1157 (let1 xx (quasi* xs (- level 1)) 1158 (if (and ($const? xx) ($const? yy)) 1159 ($const (acons op ($const-value xx) ($const-value yy))) 1160 ($cons objs ($cons (car objs) ($const op) xx) yy)))))] 1161 [((? unquote*?) . _) ;`(... . ,xs) `(... . ,@xs) 1162 (quasi objs level)] 1163 [((? vector? x) . ys) (quasi-cons objs quasi-vector x ys level)] 1164 [(x . ys) (quasi-cons objs quasi x ys level)] 1165 [_ (quasi objs level)])) 1166 1167 ;; iforms :: [IForm] 1168 ;; rest :: IForm 1169 (define (build iforms rest) 1170 (match iforms 1171 [() rest] 1172 [(x . xs) (let1 xx (build xs rest) 1173 (if (and ($const? x) ($const? xx)) 1174 ($const (cons ($const-value x) ($const-value xx))) 1175 ($cons #f x xx)))])) 1176 1177 (define (build@ iforms rest) 1178 (match iforms 1179 [() rest] 1180 [(x . xs) (let1 xx (build@ xs rest) 1181 (if ($const? xx) 1182 (cond [(null? ($const-value xx)) x] 1183 [($const? x) ($const (append ($const-value x) 1184 ($const-value xx)))] 1185 [else ($append #f x xx)]) 1186 ($append #f x xx)))])) 1187 1188 (define (quasi-cons src quasi-car x ys level) 1189 (let ([xx (quasi-car x level)] 1190 [yy (quasi* ys level)]) 1191 (if (and ($const? xx) ($const? yy)) 1192 ($const (cons ($const-value xx) ($const-value yy))) 1193 ($cons src xx yy)))) 1194 1195 (define (quasi-vector obj level) 1196 (if (vector-has-splicing? obj) 1197 ($list->vector obj (quasi* (vector->list obj) level)) 1198 (let* ([need-construct? #f] 1199 [elts (map (^[elt] (rlet1 ee (quasi elt level) 1200 (unless ($const? ee) 1201 (set! need-construct? #t)))) 1202 (vector->list obj))]) 1203 (if need-construct? 1204 ($vector obj elts) 1205 ($const (list->vector (map (^[e] ($const-value e)) elts))))))) 1206 1207 (define (vector-has-splicing? obj) 1208 (let loop ((i 0)) 1209 (cond [(= i (vector-length obj)) #f] 1210 [(and (pair? (vector-ref obj i)) 1211 (unquote-splicing? (car (vector-ref obj i))))] 1212 [else (loop (+ i 1))]))) 1213 1214 (quasi obj 0)) 1215 1216 1217;; Lambda family (binding constructs) ................... 1218 1219(define-pass1-syntax (lambda form cenv) :null ;RnRS lambda 1220 (match form 1221 [(_ formals . body) 1222 (receive (reqs rest) 1223 (let loop ((xs formals) (ys '())) 1224 (cond [(null? xs) (values (reverse ys) #f)] 1225 [(identifier? xs) (values (reverse ys) xs)] 1226 [(pair? xs) 1227 (unless (identifier? (car xs)) 1228 (error "Invalid formal parameter:" (car xs))) 1229 (loop (cdr xs) (cons (car xs) ys))] 1230 [else (error "Invalid formal parameter:" formals)])) 1231 (pass1/vanilla-lambda (add-arg-info form formals) 1232 (if rest (append reqs (list rest)) reqs) 1233 (length reqs) 1234 (if rest 1 0) 1235 body cenv))] 1236 [_ (error "syntax-error: malformed lambda:" form)])) 1237 1238(define-pass1-syntax (lambda form cenv) :gauche ;Extended lambda 1239 (match form 1240 [(_ formals . body) 1241 (receive (args nreqs nopts kargs) (parse-extended-lambda-args formals) 1242 (if (null? kargs) 1243 (pass1/vanilla-lambda (add-arg-info form formals) 1244 args nreqs nopts body cenv) 1245 ;; Convert extended lambda into vanilla lambda 1246 (let1 restarg (gensym "rest") 1247 (pass1/vanilla-lambda (add-arg-info form formals) 1248 (append args (list restarg)) 1249 nreqs 1 1250 (pass1/extended-lambda-body form cenv restarg 1251 kargs body) 1252 cenv))))] 1253 [_ (error "syntax-error: malformed lambda:" form)])) 1254 1255;; Add formals list as 'arg-info attributes of the source form 1256(define (add-arg-info form formals) 1257 (rlet1 xform (if (extended-pair? form) 1258 form 1259 (extended-cons (car form) (cdr form))) 1260 (pair-attribute-set! xform 'arg-info formals))) 1261 1262(define (pass1/vanilla-lambda form formals nreqs nopts body cenv) ; R7RS lambda 1263 (let* ([lvars (imap make-lvar+ formals)] 1264 [intform ($lambda form (cenv-exp-name cenv) nreqs nopts lvars #f #f)] 1265 [newenv (cenv-extend/proc cenv (%map-cons formals lvars) 1266 LEXICAL intform)]) 1267 (vector-set! intform 6 (pass1/body body newenv)) 1268 intform)) 1269 1270(define-pass1-syntax (receive form cenv) :gauche 1271 (match form 1272 [(_ formals expr body ...) 1273 (receive (args nreqs nopts kargs) (parse-extended-lambda-args formals) 1274 (unless (null? kargs) 1275 (error "syntax-error: extended lambda list isn't allowed in receive:" 1276 form)) 1277 (let* ([lvars (imap make-lvar+ args)] 1278 [newenv (cenv-extend cenv (%map-cons args lvars) LEXICAL)]) 1279 ($receive form nreqs nopts lvars (pass1 expr cenv) 1280 (pass1/body body newenv))))] 1281 [_ (error "syntax-error: malformed receive:" form)])) 1282 1283;; Returns <list of args>, <# of reqargs>, <has optarg?>, <kargs> 1284;; <kargs> is like (:optional (x #f) (y #f) :rest k) etc. 1285(define (parse-extended-lambda-args formals) 1286 (let loop ([formals formals] [args '()] [n 0]) 1287 (match formals 1288 [() (values (reverse args) n 0 '())] 1289 [((? keyword-like?) . _) (values (reverse args) n 1 formals)] 1290 [(x . y) (loop (cdr formals) (cons (car formals) args) (+ n 1))] 1291 [x (values (reverse (cons x args)) n 1 '())]))) 1292 1293;; Handles extended lambda list. garg is a gensymed var that receives 1294;; restarg. 1295(define (pass1/extended-lambda-body form cenv garg kargs body) 1296 (define (collect-args xs r) 1297 (match xs 1298 [() (values (reverse r) '())] 1299 [((? keyword-like?) . _) (values (reverse r) xs)] 1300 [(var . rest) (collect-args rest (cons var r))])) 1301 (define (parse-kargs c xs os ks r a) 1302 (match xs 1303 [() (expand-opt os ks r a)] 1304 [(k . xs) 1305 (cond 1306 [(global-keyword-eq? k :optional c) 1307 (unless (null? os) (too-many :optional)) 1308 (receive (os xs) (collect-args xs '()) (parse-kargs c xs os ks r a))] 1309 [(global-keyword-eq? k :key c) 1310 (unless (null? ks) (too-many :key)) 1311 (receive (ks xs) (collect-args xs '()) (parse-kargs c xs os ks r a))] 1312 [(global-keyword-eq? k :rest c) 1313 (when r (too-many :rest)) 1314 (receive (rs xs) (collect-args xs '()) 1315 (match rs 1316 [(r) (parse-kargs c xs os ks r a)] 1317 [_ (error ":rest keyword in the extended lambda list must be \ 1318 followed by exactly one argument:" kargs)]))] 1319 [(global-keyword-eq? k :allow-other-keys c) 1320 (when a (too-many :allow-other-keys)) 1321 (receive (a xs) (collect-args xs '()) 1322 (match a 1323 [() (parse-kargs c xs os ks r #t)] 1324 [(av) (parse-kargs c xs os ks r av)] 1325 [_ (error ":allow-other-keys keyword in the extended lambda list \ 1326 can be followed by zero or one argument:" kargs)]))] 1327 [else (error "invalid extended lambda list:" kargs)])])) 1328 (define (too-many key) 1329 (errorf "too many ~s keywords in the extended lambda list: ~s" key kargs)) 1330 (define (expand-opt os ks r a) 1331 (if (null? os) 1332 (if r 1333 `((,let. ((,r ,garg)) ,@(expand-key ks garg a))) 1334 (expand-key ks garg a)) 1335 (let ([binds (map (match-lambda 1336 [[? identifier? o] o] 1337 [(o init) `(,o ,init)] 1338 [_ (error "illegal optional argument spec in " kargs)]) 1339 os)] 1340 [rest (or r (gensym))]) 1341 `((,let-optionals*. ,garg ,(append binds rest) 1342 ,@(if (and (not r) (null? ks) (not a)) 1343 ;; TODO: better error message! 1344 `((unless (null? ,rest) 1345 (error "too many arguments for" ',form)) 1346 (let () ,@(expand-key ks rest a))) 1347 (expand-key ks rest a))))))) 1348 (define (expand-key ks garg a) 1349 (if (null? ks) 1350 (if a 1351 ;; The case when we have :allow-other-keys without :key. 1352 ;; We don't deal with specific keyword arguments, but expecting 1353 ;; the user provides some. Using let-keywords* checks the 1354 ;; argument list is even. 1355 `((,let-keywords*. ,garg ,(if (boolean? a) (gensym) a) ,@body)) 1356 body) 1357 (let1 args (map (match-lambda 1358 [[? identifier? o] o] 1359 [(([? keyword-like? key] o) init) 1360 (let1 k (unwrap-syntax-1 key) 1361 `(,o ,k ,init))] 1362 [(o init) `(,o ,init)] 1363 [_ (error "illegal keyword argument spec in " kargs)]) 1364 ks) 1365 `((,let-keywords*. ,garg 1366 ,(if a (append args a) args) 1367 ,@body))))) 1368 1369 (parse-kargs cenv kargs '() '() #f #f)) 1370 1371;; case-lambda (srfi-16) 1372;; we recognize it here so that we can do aggressive inlining. 1373(define-pass1-syntax (case-lambda form cenv) :gauche 1374 (match form 1375 [(_ (formals . body)) ; special case 1376 (pass1 `(,lambda. ,formals ,@body) cenv)] 1377 [(_) (error "syntax-error: malformed case-lambda:" form)] 1378 [(_ (formals . body) ...) 1379 (receive (min-req max-req) (find-argcount-minmax formals) 1380 (pass1 `(,make-case-lambda. 1381 ,min-req ,max-req ',formals 1382 (list ,@(map (^(f b) `(,lambda. ,f ,@b)) formals body)) 1383 ',(cenv-exp-name cenv)) 1384 cenv))] 1385 [_ (error "syntax-error: malformed case-lambda:" form)])) 1386 1387(define (find-argcount-minmax formals) 1388 (define (length. xs k) 1389 (if (pair? xs) (length. (cdr xs) (+ k 1)) k)) 1390 (let loop ([formals formals] [min-req #f] [max-req 0]) 1391 (if (null? formals) 1392 (values min-req max-req) 1393 (let1 k (length. (car formals) 0) 1394 (loop (cdr formals) (if min-req (min min-req k) k) (max max-req k)))))) 1395 1396(define-pass1-syntax (let form cenv) :null 1397 (match form 1398 [(_ () body ...) 1399 (pass1/body body cenv)] 1400 [(_ ((var expr) ...) body ...) 1401 (let* ([lvars (imap make-lvar+ var)] 1402 [newenv (cenv-extend cenv (%map-cons var lvars) LEXICAL)]) 1403 ($let form 'let lvars 1404 (map (^[init lvar] 1405 (rlet1 iexpr 1406 (pass1 init (cenv-add-name cenv (lvar-name lvar))) 1407 (lvar-initval-set! lvar iexpr))) 1408 expr lvars) 1409 (pass1/body body newenv)))] 1410 [(_ name ((var expr) ...) body ...) 1411 (unless (identifier? name) (error "bad name for named let:" name)) 1412 ;; Named let. (let name ((var exp) ...) body ...) 1413 ;; 1414 ;; We don't use the textbook expansion here 1415 ;; ((letrec ((name (lambda (var ...) body ...))) name) exp ...) 1416 ;; 1417 ;; Instead, we use the following expansion, except that we cheat 1418 ;; environment during expanding {exp ...} so that the binding of 1419 ;; name doesn't interfere with exp .... 1420 ;; 1421 ;; (letrec ((name (lambda (var ...) body ...))) (name {exp ...})) 1422 ;; 1423 ;; The reason is that this form can be more easily spotted by 1424 ;; our simple-minded closure optimizer in Pass 2. 1425 (let ([lvar (make-lvar name)] 1426 [args (imap make-lvar+ var)] 1427 [argenv (cenv-sans-name cenv)]) 1428 (let* ([env1 (cenv-extend cenv `((,name . ,lvar)) LEXICAL)] 1429 [env2 (cenv-extend/name env1 (%map-cons var args) LEXICAL name)] 1430 [lmda ($lambda form name (length args) 0 args 1431 (pass1/body body env2))]) 1432 (lvar-initval-set! lvar lmda) 1433 ($let form 'rec 1434 (list lvar) 1435 (list lmda) 1436 ($call #f ($lref lvar) 1437 (imap (cut pass1 <> argenv) expr)))))] 1438 [_ (error "syntax-error: malformed let:" form)])) 1439 1440(define-pass1-syntax (let* form cenv) :null 1441 (match form 1442 [(_ ((var expr) ...) body ...) 1443 (let loop ([vars var] [inits expr] [cenv cenv]) 1444 (if (null? vars) 1445 (pass1/body body cenv) 1446 (let* ([lv (make-lvar (car vars))] 1447 [newenv (cenv-extend cenv `((,(car vars) . ,lv)) LEXICAL)] 1448 [iexpr (pass1 (car inits) (cenv-add-name cenv (car vars)))]) 1449 (lvar-initval-set! lv iexpr) 1450 ($let #f 'let (list lv) (list iexpr) 1451 (loop (cdr vars) (cdr inits) newenv)))))] 1452 [_ (error "syntax-error: malformed let*:" form)])) 1453 1454(define-pass1-syntax (letrec form cenv) :null 1455 (pass1/letrec form cenv "letrec" 'rec)) 1456 1457(define-pass1-syntax (letrec* form cenv) :gauche 1458 (pass1/letrec form cenv "letrec*" 'rec*)) 1459 1460(define (pass1/letrec form cenv name type) 1461 (match form 1462 [(_ () body ...) 1463 (pass1/body body cenv)] 1464 [(_ ((var expr) ...) body ...) 1465 (let* ([lvars (imap make-lvar+ var)] 1466 [newenv (cenv-extend cenv (%map-cons var lvars) LEXICAL)]) 1467 ($let form type lvars 1468 (map (^[lv init] 1469 (rlet1 iexpr 1470 (pass1 init (cenv-add-name newenv (lvar-name lv))) 1471 (lvar-initval-set! lv iexpr))) 1472 lvars expr) 1473 (pass1/body body newenv)))] 1474 [else (errorf "syntax-error: malformed ~a: ~s" name form)])) 1475 1476(define-pass1-syntax (do form cenv) :null 1477 (match form 1478 [(_ ((var init . update) ...) (test expr ...) body ...) 1479 (let* ([tmp (make-lvar 'do-proc)] 1480 [args (imap make-lvar+ var)] 1481 [newenv (cenv-extend/proc cenv (%map-cons var args) 1482 LEXICAL 'do-proc)] 1483 [clo ($lambda 1484 form 'do-body (length var) 0 args 1485 ($if #f 1486 (pass1 test newenv) 1487 (if (null? expr) 1488 ($it) 1489 ($seq (imap (cut pass1 <> newenv) expr))) 1490 ($seq 1491 (list 1492 (pass1/body body newenv) 1493 ($call form 1494 ($lref tmp) 1495 (map (match-lambda* 1496 [(() arg) ($lref arg)] 1497 [((expr) _) (pass1 expr newenv)] 1498 [_ (error "bad update expr in do:" form)]) 1499 update args))))) 1500 #f)]) 1501 (lvar-initval-set! tmp clo) 1502 ($let form 'rec 1503 (list tmp) 1504 (list clo) 1505 ($call form 1506 ($lref tmp) 1507 (map (cute pass1 <> (cenv-sans-name cenv)) init))))] 1508 [else (error "syntax-error: malformed do:" form)])) 1509 1510;; Set! ...................................................... 1511 1512(define-pass1-syntax (set! form cenv) :null 1513 (match form 1514 [(_ (op . args) expr) 1515 ;; srfi-17. We recurse to pass1 on expanded form, for (setter op) might 1516 ;; have a chance of optimization. 1517 (pass1 (with-original-source `((,setter. ,op) ,@args ,expr) form) cenv)] 1518 [(_ name expr) 1519 (unless (identifier? name) 1520 (error "syntax-error: malformed set!:" form)) 1521 (let ([var (cenv-lookup-variable cenv name)] 1522 [val (pass1 expr cenv)]) 1523 (if (lvar? var) 1524 ($lset var val) 1525 ($gset (ensure-identifier var cenv) val)))] 1526 [_ (error "syntax-error: malformed set!:" form)])) 1527 1528;; Begin ..................................................... 1529 1530(define-pass1-syntax (begin form cenv) :null 1531 ($seq (imap (cut pass1 <> cenv) (cdr form)))) 1532 1533;; Lazy & Delay .............................................. 1534 1535(define-pass1-syntax (lazy form cenv) :gauche 1536 (match form 1537 [(_ expr) ($asm form `(,PROMISE) 1538 (list (pass1 `(,lambda. () ,expr) cenv)))] 1539 [_ (error "syntax-error: malformed lazy:" form)])) 1540 1541(define-pass1-syntax (delay form cenv) :null 1542 (match form 1543 [(_ expr) (pass1 `(,lazy. (,eager. ,expr)) cenv)] 1544 [_ (error "syntax-error: malformed delay:" form)])) 1545 1546;; Module related ............................................ 1547 1548(define-pass1-syntax (define-module form cenv) :gauche 1549 (check-toplevel form cenv) 1550 (match form 1551 [(_ name body ...) 1552 (let* ([mod (ensure-module name 'define-module #t)] 1553 [newenv (make-bottom-cenv mod)]) 1554 ($seq (imap (cut pass1 <> newenv) body)))] 1555 [_ (error "syntax-error: malformed define-module:" form)])) 1556 1557(define-pass1-syntax (with-module form cenv) :gauche 1558 (match form 1559 [(_ name body ...) 1560 (let* ([mod (ensure-module name 'with-module #f)] 1561 [newenv (cenv-swap-module cenv mod)]) 1562 ($seq (imap (cut pass1 <> newenv) body)))] 1563 [_ (error "syntax-error: malformed with-module:" form)])) 1564 1565(define-pass1-syntax (select-module form cenv) :gauche 1566 (check-toplevel form cenv) 1567 (match form 1568 [(_ module) 1569 ;; This is the only construct that changes VM's current module. 1570 ;; We also modifies CENV's module, so that select-module has an 1571 ;; effect in the middle of sequence of expressions like 1572 ;; (begin ... (select-module foo) ...) 1573 ;; It is yet debatable that how select-module should interact with EVAL. 1574 (let1 m (ensure-module module 'select-module #f) 1575 (vm-set-current-module m) 1576 (cenv-module-set! cenv m) 1577 ($values0))] 1578 [else (error "syntax-error: malformed select-module:" form)])) 1579 1580(define-pass1-syntax (current-module form cenv) :gauche 1581 (unless (null? (cdr form)) 1582 (error "syntax-error: malformed current-module:" form)) 1583 ($const (cenv-module cenv))) 1584 1585(define-pass1-syntax (export form cenv) :gauche 1586 (%export-symbols (cenv-module cenv) (cdr form)) 1587 ($values0)) 1588 1589(define-pass1-syntax (export-all form cenv) :gauche 1590 (unless (null? (cdr form)) 1591 (error "syntax-error: malformed export-all:" form)) 1592 (%export-all (cenv-module cenv)) 1593 ($values0)) 1594 1595(define-pass1-syntax (import form cenv) :gauche 1596 (define (ensure m) (or (find-module m) (error "unknown module" m))) 1597 (define (symbol-but-not-keyword? x) 1598 (and (symbol? x) (not (keyword? x)))) 1599 (dolist [f (cdr form)] 1600 (match f 1601 [((? symbol-but-not-keyword? a) (? symbol-but-not-keyword? b) . r) 1602 ;;likely to be an r7rs-style import 1603 (error "This import form looks like R7RS `import', as opposed to \ 1604 Gauche `import'. If you're in REPL, type (use scheme.base) \ 1605 then (select-module r7rs.user) to enter the R7RS namespace.")] 1606 [(m . r) (process-import (cenv-module cenv) (ensure m) r)] 1607 [m (process-import (cenv-module cenv) (ensure m) '())])) 1608 ($values0)) 1609 1610(define (process-import current imported args) 1611 (let loop ([imported imported] 1612 [args args] 1613 [prefix #f]) 1614 (match args 1615 [() (%import-module current imported prefix)] 1616 [(':prefix p . rest) 1617 (loop imported rest (if prefix (string->symbol #"~|p|~prefix") p))] 1618 [(':only (ss ...) . rest) 1619 (let1 m (%make-wrapper-module imported prefix) 1620 (process-import:mapsym 1621 :only (unwrap-syntax ss) #f prefix 1622 (^[sym orig-sym] (unless (%alias-binding m orig-sym imported orig-sym) 1623 (errorf "during processing :only clause: \ 1624 binding of ~a isn't exported from ~a" 1625 orig-sym imported)))) 1626 (%extend-module m '()) 1627 (loop m rest #f))] 1628 [(':except (ss ...) . rest) 1629 (let1 m (%make-wrapper-module imported prefix) 1630 (process-import:mapsym 1631 :except (unwrap-syntax ss) #f prefix 1632 (^[sym orig-sym] (%hide-binding m orig-sym))) 1633 (loop m rest #f))] 1634 [(':rename ((ss ds) ...) . rest) 1635 (let* ([ss (unwrap-syntax ss)] 1636 [ds (unwrap-syntax ds)] 1637 [m0 (if prefix (%make-wrapper-module imported prefix) imported)] 1638 [m (%make-wrapper-module imported #f)]) 1639 (process-import:mapsym 1640 :rename ds ss prefix 1641 (^[sym orig-sym] (unless (%alias-binding m sym imported orig-sym) 1642 (errorf "during processing :rename clause: \ 1643 binding of ~a isn't exported from ~a" 1644 orig-sym imported)))) 1645 (dolist [s ss] (unless (find-binding m s #t) (%hide-binding m s))) 1646 (%extend-module m (list m0)) 1647 (loop m rest #f))] 1648 [(other . rest) (error "invalid import spec:" args)]))) 1649 1650;; Common work to process new bindings in a trampoline module. 1651;; Calls PROCESS with each symbols in SYMS and OLD-SYMS, but 1652;; symbols in OLD-SYMS are prefix-stripped. OLD-SYMS can be #f 1653;; then we assume it is the same as SYMS. 1654(define (process-import:mapsym who syms old-syms prefix process) 1655 (define (check s) 1656 (unless (symbol? s) 1657 (errorf "~a option of import must take list of symbols, but got: ~s" 1658 who s))) 1659 (for-each (^[sym osym] 1660 (check sym) (check osym) 1661 (process sym (process-import:strip-prefix who osym prefix))) 1662 syms (or old-syms syms))) 1663 1664(define (process-import:strip-prefix who sym prefix) 1665 (if prefix 1666 (rlet1 sans (symbol-sans-prefix sym prefix) 1667 (unless sans (errorf "~a specifies nonexistent symbol: ~a" who sym))) 1668 sym)) 1669 1670(define-pass1-syntax (extend form cenv) :gauche 1671 (%extend-module (cenv-module cenv) 1672 (imap (^[m] (or (find-module m) 1673 (begin 1674 (%require (module-name->path m)) 1675 (find-module m)) 1676 (error "undefined module" m))) 1677 (cdr form))) 1678 ($values0)) 1679 1680(define-pass1-syntax (require form cenv) :gauche 1681 (match form 1682 [(_ feature) (%require feature) ($values0)] 1683 [_ (error "syntax-error: malformed require:" form)])) 1684 1685;; Include ............................................. 1686 1687(define-pass1-syntax (include form cenv) :gauche 1688 ($seq (map (^p (pass1 (car p) (cenv-swap-source cenv (cdr p)))) 1689 (pass1/expand-include (cdr form) cenv #f)))) 1690 1691(define-pass1-syntax (include-ci form cenv) :gauche 1692 ($seq (map (^p (pass1 (car p) (cenv-swap-source cenv (cdr p)))) 1693 (pass1/expand-include (cdr form) cenv #t)))) 1694 1695;; Returns ((Sexpr . Filename) ...) 1696(define (pass1/expand-include args cenv case-fold?) 1697 (define (do-include filename) 1698 (unless (string? filename) 1699 (error "include requires literal string, but got:" filename)) 1700 (let1 iport (pass1/open-include-file filename (cenv-source-path cenv)) 1701 (port-case-fold-set! iport case-fold?) 1702 (pass1/report-include iport #t) 1703 (unwind-protect 1704 ;; This could be written simpler using port->sexp-list, but it would 1705 ;; trigger autoload and reenters to the compiler. 1706 (let loop ([r (read iport)] [forms '()]) 1707 (if (eof-object? r) 1708 `((,begin. ,@(reverse forms)) . ,(port-name iport)) 1709 (loop (read iport) (cons r forms)))) 1710 (pass1/report-include iport #f) 1711 (close-input-port iport)))) 1712 (map do-include args)) 1713 1714;; If filename is relative, we try to resolve it with the source file. 1715;; whenever possible. 1716(define (pass1/open-include-file path includer-path) 1717 (let1 search-paths (if includer-path 1718 (cons (sys-dirname includer-path) *load-path*) 1719 *load-path*) 1720 ;; find-load-file returns either (<found-path> <rest-of-search-paths>) 1721 ;; or (<pseudo-path> <rest-of-search-paths> <thunk-to-open-content>) 1722 ;; see libeval.scm for the details. 1723 (if-let1 path&rest (find-load-file path search-paths 1724 (cons "" *load-suffixes*) 1725 :allow-archive #t 1726 :relative-dot-path #t) 1727 (if (pair? (cddr path&rest)) ; archive hook is in effect. 1728 ((caddr path&rest) (car path&rest)) 1729 (open-input-file (car path&rest) :encoding #t)) 1730 (error "include file is not readable: " path)))) 1731 1732;; Report including. 1733(define (pass1/report-include iport open?) 1734 (when (vm-compiler-flag-is-set? SCM_COMPILE_INCLUDE_VERBOSE) 1735 (format (current-error-port) ";;~a including ~s\n" 1736 (if open? "Begin" "End") (port-name iport)))) 1737 1738;; Class stuff ........................................ 1739 1740;; KLUDGES. They should be implemented as macros, but the 1741;; current compiler doesn't preserve macro definitions. 1742;; These syntax handler merely expands the given form to 1743;; the call to internal procedures of objlib.scm, which 1744;; returns the macro expanded form. 1745 1746(define-pass1-syntax (define-generic form cenv) :gauche 1747 (match form 1748 [(_ name . opts) 1749 (check-toplevel form cenv) 1750 (pass1 (with-module gauche.object (%expand-define-generic name opts)) cenv)] 1751 [_ (error "syntax-error: malformed define-generic:" form)])) 1752 1753(define-pass1-syntax (define-method form cenv) :gauche 1754 (define (parse name rest quals) 1755 (match rest 1756 [((? keyword? q) . rest) 1757 (parse name rest (cons q quals))] 1758 [(specs . body) 1759 (pass1 (with-module gauche.object 1760 (%expand-define-method name quals specs body)) 1761 cenv)] 1762 [_ (error "syntax-error: malformed define-method (empty body):" form)])) 1763 ;; Should we limit define-method only at the toplevel? Doing so 1764 ;; is consistent with toplevel define and define-syntax. Allowing 1765 ;; define-method in non-toplevel is rather CL-ish and not like Scheme. 1766 ;; (check-toplevel form cenv) 1767 (match form 1768 [(_ name . rest) 1769 (parse name rest '())] 1770 [_ (error "syntax-error: malformed define-method:" form)])) 1771 1772(define-pass1-syntax (define-class form cenv) :gauche 1773 (match form 1774 [(_ name supers slots . options) 1775 (check-toplevel form cenv) 1776 (pass1 (with-module gauche.object 1777 (%expand-define-class name supers slots options)) 1778 cenv)] 1779 [_ (error "syntax-error: malformed define-class:" form)])) 1780 1781;; Black magic ........................................ 1782 1783(define-pass1-syntax (eval-when form cenv) :gauche 1784 (match form 1785 [(_ (w ...) expr ...) 1786 ;; check 1787 (let ([wlist 1788 (let loop ((w w) (r '())) 1789 (cond [(null? w) r] 1790 [(memq (car w) '(:compile-toplevel :load-toplevel :execute)) 1791 (if (memq (car w) r) 1792 (loop (cdr w) r) 1793 (loop (cdr w) (cons (car w) r)))] 1794 [else 1795 (error "eval-when: situation must be a list of \ 1796 :compile-toplevel, :load-toplevel or :execute, \ 1797 but got:" (car w))]))] 1798 [situ (vm-eval-situation)]) 1799 (when (and (eqv? situ SCM_VM_COMPILING) 1800 (memq :compile-toplevel wlist) 1801 (cenv-toplevel? cenv)) 1802 (dolist [e expr] (eval e (cenv-module cenv)))) 1803 (if (or (and (eqv? situ SCM_VM_LOADING) 1804 (memq :load-toplevel wlist) 1805 (cenv-toplevel? cenv)) 1806 (and (eqv? situ SCM_VM_EXECUTING) 1807 (memq :execute wlist))) 1808 ($seq (imap (cut pass1 <> cenv) expr)) 1809 ($const-undef)))] 1810 [_ (error "syntax-error: malformed eval-when:" form)])) 1811 1812#| 1813(define-pass1-syntax (with-meta form cenv) :gauche 1814 (match form 1815 [(_ (meta ...) expr) 1816 (let1 exp (pass1 expr cenv) 1817 exp)] 1818 [_ (error "syntax-error: malformed with-meta:" form)])) 1819|# 1820 1821