1;;; 2;;; gauche.cgen.cise - C in S expression 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(define-module gauche.cgen.cise 35 (use srfi-13) 36 (use gauche.sequence) 37 (use gauche.parameter) 38 (use gauche.cgen.unit) 39 (use gauche.cgen.literal) 40 (use gauche.experimental.lamb) 41 (use util.match) 42 (export cise-render cise-render-to-string cise-render-rec 43 cise-translate 44 cise-ambient cise-default-ambient cise-ambient-copy 45 cise-push-static-decl! cise-ambient-decl-strings 46 cise-register-macro! 47 cise-lookup-macro 48 cise-emit-source-line 49 define-cise-macro 50 define-cise-stmt 51 define-cise-expr 52 define-cise-toplevel 53 ) 54 ) 55(select-module gauche.cgen.cise) 56 57;;============================================================= 58;; Parameters 59;; 60 61;; If true, include #line directive in the output. 62(define cise-emit-source-line (make-parameter #t)) 63 64;; The global settings 65(define-class <cise-ambient> () 66 (;; CiSE macro definitions 67 ;; The default cise-ambient holds all predefined macros; you can 68 ;; copy the default ambient and add custom macros. 69 (macros :init-keyword :macros :init-form (make-hash-table 'eq?)) 70 ;; Stree for forward declarations. Some macros, such as define-cfn, 71 ;; insert this. This must be emitted at toplevel, so local 72 ;; transformation functions such as cise-render DOES NOT emit 73 ;; the code put here. Cise-translate does. If the caller only calls 74 ;; local transformation functions and need to expand macros that 75 ;; generates static-decls, the caller has to call emit-static-decls 76 ;; at the point where toplevel code is allowed. 77 ;; NB: If you're translating entire unit (e.g. dealing with stubs) 78 ;; you should use cgen-unit features direcly to register toplevel 79 ;; code. This is to keep transient info mainly used by cise-translate. 80 (static-decls :init-keyword :static-decls :init-value '()))) 81 82;; The default ambient - this should be only modified during loading of 83;; this module, in order to register all the default cise macros. Once 84;; this module is loaded, this must be treated as immutable, and the 85;; user must get its copy to use via cise-default-ambient. 86(define *default-ambient* (make <cise-ambient>)) 87 88;; Returns a copy of the default ambient 89(define (cise-default-ambient) (cise-ambient-copy *default-ambient* '())) 90 91;; Keeps the cise macro bindings. 92;; We initialize it with *default-ambient* so that it gets all the cise 93;; macros in this module. At the end of this module we replace its 94;; value with a copy, so that the default ambient is "sealed". 95(define cise-ambient (make-parameter *default-ambient*)) 96 97;;============================================================= 98;; Environment 99;; 100 101;; Environment keeps transient information during cise macro expansion. 102;; It must be treated opaque from outside of CISE module. 103(define-class <cise-env> () 104 ((context :init-keyword :context) ; toplevel, stmt or expr 105 (decls :init-keyword :decls) ; list of extra decls 106 )) 107 108(define (make-env context decls) 109 (make <cise-env> :context context :decls decls)) 110(define (env-ctx env) (~ env'context)) 111(define (env-decls env) (~ env'decls)) 112(define (expr-ctx? env) (eq? (env-ctx env) 'expr)) 113(define (stmt-ctx? env) (eq? (env-ctx env) 'stmt)) 114(define (toplevel-ctx? env) (eq? (env-ctx env) 'toplevel)) 115 116(define (null-env) (make-env 'stmt '())) 117 118(define (expr-env env) 119 (if (expr-ctx? env) env (make-env 'expr (env-decls env)))) 120(define (stmt-env env) 121 (if (stmt-ctx? env) env (make-env 'stmt (env-decls env)))) 122 123(define (ensure-stmt-ctx form env) 124 (unless (stmt-ctx? env) 125 (if (expr-ctx? env) 126 (error "cise: statement appears in an expression context:" form) 127 (error "cise: statement appears in a toplevel context:" form)))) 128 129(define (ensure-toplevel-ctx form env) 130 (unless (toplevel-ctx? env) 131 (error "cise: form can only appear in toplevel:" form))) 132(define (ensure-stmt-or-toplevel-ctx form env) 133 (unless (or (toplevel-ctx? env) (stmt-ctx? env)) 134 (error "cise: form can only appear in toplevel or statement context:" form))) 135(define (env-decl-add! env decl) 136 (push! (~ env'decls) decl)) 137 138(define (wrap-expr form env) 139 (if (expr-ctx? env) form `(,form ";"))) 140 141(define (render-env-decls env) 142 (map (^.[(var type) `(,(cise-render-typed-var type var env) ";")]) 143 (env-decls env))) 144 145;; Check source-info attribute of the input S-expr, and returns Stree 146;; of "#line" line if necessary. 147(define (source-info form env) 148 (if (not (cise-emit-source-line)) 149 '() 150 (match (debug-source-info form) 151 [((? string? file) line) 152 `((source-info ,file ,line))] 153 [_ '()]))) 154 155;;============================================================= 156;; Global decls 157;; NB: See the note in cise-ambient definition above. 158;; Usually you don't need to use these---just use cise-unit API instead. 159 160(define (cise-push-static-decl! stree :optional (ambient (cise-ambient))) 161 (push! (~ ambient'static-decls) stree)) 162 163(define (cise-push-static-decl-unique! stree :optional (ambient (cise-ambient))) 164 (unless (memq stree (~ ambient'static-decls)) 165 (push! (~ ambient'static-decls) stree))) 166 167(define (emit-static-decls port :optional (ambient (cise-ambient))) 168 (dolist [stree (reverse (~ ambient'static-decls))] 169 (render-finalize stree port)) 170 (set! (~ ambient'static-decls) '())) 171 172;; external API 173(define (cise-ambient-decl-strings ambient) 174 (call-with-output-string 175 (cut emit-static-decls <> ambient))) 176 177;;============================================================= 178;; Expander 179;; 180;; Cgen expander knows little about C. It handles literals 181;; (strings, numbers, booleans, and characters) and function calls. 182;; All other stuff is handled by "cise macros" 183 184;; 185;; cise-register-macro! NAME EXPANDER &optional AMBIENT 186;; 187;; Register cise macro expander EXPANDER with the name NAME. 188;; EXPANDER takes twi arguments, the form to expand and a 189;; opaque cise environmen. 190;; 191(define (cise-register-macro! name expander :optional (ambient (cise-ambient))) 192 (hash-table-put! (~ ambient'macros) name expander)) 193 194;; 195;; cise-lookup-macro NAME &optional AMBIENT 196;; 197;; Lookup cise macro. 198;; 199(define (cise-lookup-macro name :optional (ambient (cise-ambient))) 200 (hash-table-get (~ ambient'macros) name #f)) 201 202;; 203;; copy the current cise ambient 204;; 205;; By default, static-decls are copied. It's useful when you save 206;; the snapshot of ambient for the later retry. Another usage is 207;; to have a transient "child" ambient, where you add new macros, 208;; emit something, and come back to the original ambient. In that 209;; case you want to clear out static-decls. Hence we have the second 210;; argument. NB: This spec smells fishy. May change later. 211(define (cise-ambient-copy :optional 212 (ambient (cise-ambient)) 213 (static-decls (~ ambient'static-decls))) 214 (make <cise-ambient> 215 :macros (hash-table-copy (~ ambient'macros)) 216 :static-decls static-decls)) 217 218;; 219;; define-cise-macro (OP FORM ENV) . BODY 220;; 221;; Default syntax to add new cise macro to the current ambient. 222;; 223(define-syntax define-cise-macro 224 (syntax-rules () 225 [(_ (op form env) . body) 226 (cise-register-macro! 'op (lambda (form env) . body))] 227 [(_ op op2) ; alias 228 (cise-register-macro! 'op (or (cise-lookup-macro 'op2) 229 (error "unknown cise macro:" 'op2)))])) 230;; 231;; define-cise-stmt OP [ENV] CLAUSE ... [:where DEFINITION ...] 232;; define-cise-expr OP [ENV] CLAUSE ... [:where DEFINITION ...] 233;; define-cise-toplevel OP [ENV] CLAUSE ... [:where DEFINITION ...] 234;; 235 236(define-syntax define-cise-stmt 237 (syntax-rules (:where) 238 ;; recursion 239 [(_ "clauses" op env clauses (:where defs ...)) 240 (define-cise-macro (op form env) 241 defs ... 242 (ensure-stmt-ctx form env) 243 (match form . clauses))] 244 [(_ "clauses" op env clauses ()) 245 (define-cise-stmt "clauses" op env clauses (:where))] 246 [(_ "clauses" op env (clause ...) (x . y)) 247 (define-cise-stmt "clauses" op env (clause ... x) y)] 248 ;; entry 249 [(_ (op . args) . body) ; single pattern case 250 (define-cise-stmt "clauses" op env (((_ . args) . body)) ())] 251 [(_ op (pat . body) . clauses) ; (pat . body) rules out a single symbol 252 (define-cise-stmt "clauses" op env ((pat . body)) clauses)] 253 [(_ op env . clauses) 254 (define-cise-stmt "clauses" op env () clauses)])) 255 256(define-syntax define-cise-expr 257 (syntax-rules (:where) 258 ;; recursion 259 [(_ "clauses" op env clauses (:where defs ...)) 260 (define-cise-macro (op form env) 261 defs ... 262 (let1 expanded (match form . clauses) 263 (if (and (pair? expanded) (symbol? (car expanded))) 264 (render-rec expanded env) 265 (wrap-expr expanded env))))] 266 [(_ "clauses" op env clauses ()) 267 (define-cise-expr "clauses" op env clauses (:where))] 268 [(_ "clauses" op env (clause ...) (x . y)) 269 (define-cise-expr "clauses" op env (clause ... x) y)] 270 ;; entry 271 [(_ (op . args) . body) ; single pattern case 272 (define-cise-expr "clauses" op env (((_ . args) . body)) ())] 273 [(_ op (pat . body) . clauses) 274 (define-cise-expr "clauses" op env ((pat . body)) clauses)] 275 [(_ op env . clauses) 276 (define-cise-expr "clauses" op env () clauses)])) 277 278(define-syntax define-cise-toplevel 279 (syntax-rules (:where) 280 ;; recursion 281 [(_ "clauses" op env clauses (:where defs ...)) 282 (define-cise-macro (op form env) 283 defs ... 284 (ensure-toplevel-ctx form env) 285 (match form . clauses))] 286 [(_ "clauses" op env clauses ()) 287 (define-cise-toplevel "clauses" op env clauses (:where))] 288 [(_ "clauses" op env (clause ...) (x . y)) 289 (define-cise-toplevel "clauses" op env (clause ... x) y)] 290 ;; entry 291 [(_ (op . args) . body) ; single pattern case 292 (define-cise-toplevel "clauses" op env (((_ . args) . body)) ())] 293 [(_ op (pat . body) . clauses) ; (pat . body) rules out a single symbol 294 (define-cise-toplevel "clauses" op env ((pat . body)) clauses)] 295 [(_ op env . clauses) 296 (define-cise-toplevel "clauses" op env () clauses)])) 297 298;; 299;; cise-render cise &optional port context 300;; 301;; context := 'toplevel | 'stmt | 'expr | #t (expr) | #f (stmt) 302;; 303;; External entry of renderer 304;; 305(define (cise-render form :optional (port (current-output-port)) (ctx 'stmt)) 306 (let* ([env (case ctx 307 [(toplevel) (make-env 'toplevel '())] 308 [(stmt #f) (null-env)] 309 [(expr #t) (expr-env (null-env))] 310 [else (error "cise-render: invalid context:" ctx)])] 311 [stree (render-rec form env)]) 312 (render-finalize `(,@(render-env-decls env) ,stree) port))) 313 314(define (cise-render-to-string form :optional (ctx #f)) 315 (call-with-output-string (cut cise-render form <> ctx))) 316 317(define (render-finalize stree port) 318 (define current-file #f) 319 (define current-line 1) 320 (define (rec stree) 321 (match stree 322 [('source-info (? string? file) line) 323 (cond [(and (equal? file current-file) (eqv? line current-line))] 324 [(and (equal? file current-file) (eqv? line (+ 1 current-line))) 325 (inc! current-line) 326 (format port "\n")] 327 [else 328 (set! current-file file) 329 (set! current-line line) 330 (when (cise-emit-source-line) 331 (format port "\n#line ~a ~s\n" line file))])] 332 ['|#reset-line| ; reset source info 333 (set! current-file #f) (set! current-line 0)] 334 [(x . y) (rec x) (rec y)] 335 [(? (any-pred string? symbol? number?) x) (display x port)] 336 [_ #f])) 337 (rec stree)) 338 339;; 340;; cise-render-rec cise stmt/expr env 341;; 342;; External interface to call back to cise expander recursively. 343;; stmt/expr should be either a symbol stmt or expr. 344;; env must be treated as opaque object. 345;; 346(define (cise-render-rec form stmt/expr env) 347 (case stmt/expr 348 [(stmt) (render-rec form (stmt-env env))] 349 [(expr) (render-rec form (expr-env env))] 350 [else (error "cise-render-rec: second argument must be either \ 351 stmt or expr, but got:" stmt/expr)])) 352 353;; render-rec :: Cise, Env -> Stree 354;; Recursively expands Cise and generates Stree 355(define (render-rec form env) 356 (match form 357 [([? symbol? key] . args) 358 (cond [(cise-lookup-macro key) 359 => (^[expander] `(,@(source-info form env) 360 ,@(render-rec (expander form env) env)))] 361 [(or (type-decl-initial? key) 362 (any type-decl-subsequent? args)) 363 (cise-render-typed-var form "" env)] 364 [else 365 (let1 eenv (expr-env env) 366 (wrap-expr 367 `(,@(source-info form env) 368 ,(cise-render-identifier key) "(" 369 ,@(intersperse "," (map (cut render-rec <> eenv) args)) 370 ")") 371 env))])] 372 [(x . y) form] ; already stree 373 ['|#reset-line| '|#reset-line|] ; special directive to reset line info 374 [[? type-decl-initial?] (wrap-expr (cise-render-typed-var form "" env) env)] 375 ;; TRANSIENT: After 1.0, we can consolidate the following two clauses 376 [[? symbol?] (wrap-expr (cise-render-identifier form) env)] 377 [[? identifier?] (wrap-expr (cise-render-identifier (unwrap-syntax form)) 378 env)] 379 [[? string?] (wrap-expr (write-to-string form) env)] 380 [[? real?] (wrap-expr form env)] 381 [() '()] 382 [#\' (wrap-expr "'\\''" env)] 383 [#\\ (wrap-expr "'\\\\'" env)] 384 [#\newline (wrap-expr "'\\n'" env)] 385 [#\return (wrap-expr "'\\r'" env)] 386 [#\tab (wrap-expr "'\\t'" env)] 387 [[? char?] 388 (if (>= (char->integer form) 128) 389 (error "CISE: Cannot embed non-ASCII character literal (yet):" form) 390 (wrap-expr `("'" ,(if (char-set-contains? #[[:alnum:]] form) 391 (string form) 392 (format "\\x~2,'0x" (char->integer form))) 393 "'") env))] 394 [_ (error "Invalid CISE form: " form)])) 395 396;; 397;; cise-translate inp outp &key enviroment 398;; 399;; External interface to translate entire CiSE file into C. 400;; CiSE expressions are read from INP and the resulting C code 401;; is written to OUTP. 402;; 403;; If CISE-TRANSLATE encounters a form (.static-decls), 404;; it expands the rest of CiSE forms into a temporary string, 405;; then emits the forward declarations of static functions 406;; into outp, followed by the accumulated C code. With this 407;; you don't need to write forward declarations in CiSE source. 408 409(define (cise-translate inp outp 410 :key (environment (make-module #f)) 411 (ambient (cise-ambient-copy))) 412 (define (finish toutp) 413 (unless (eq? outp toutp) 414 (emit-static-decls outp) 415 (display (get-output-string toutp) outp)) 416 (newline outp)) 417 418 (eval '(use gauche.cgen.cise) environment) 419 (eval '(use util.match) environment) 420 (parameterize ([cise-ambient ambient]) 421 (let loop ([toutp outp]) 422 (match (read inp) 423 [(? eof-object?) (finish toutp)] 424 [('.raw-c-code . cs) 425 (dolist [c cs] (newline toutp) (display c toutp)) (loop toutp)] 426 [(and ((or 'define-cise-stmt 'define-cise-expr 'define-cise-toplevel) 427 . _) 428 f) 429 (eval f environment) 430 (loop toutp)] 431 [('.static-decls) (loop (open-output-string))] 432 [(and (op . _) f) 433 (if (cise-lookup-macro op) 434 (cise-render f toutp 'toplevel) 435 (eval f environment)) 436 (loop toutp)])))) 437 438;;============================================================= 439;; Built-in macros 440;; 441 442;;------------------------------------------------------------ 443;; C function definition 444;; 445 446;; (define-cfn <name> (<arg> ...) [<rettype> [<qualifier> ...]] <body>) 447;; (declare-cfn <name> (<arg> ...) [<rettype> [<qualifier> ...]]) 448 449(define-cise-macro (define-cfn form env) 450 (expand-cfn form env)) 451(define-cise-macro (declare-cfn form env) 452 (expand-cfn form env)) 453 454(define (expand-cfn form env) 455 (define (gen-args args env) 456 (let1 eenv (expr-env env) 457 ($ intersperse "," 458 $ map (^.[(var . type) (cise-render-typed-var type var eenv)]) args))) 459 460 (define (gen-qualifiers quals) ; we might support more qualifiers in future 461 (intersperse " " 462 (map (^[qual] (ecase qual 463 [(:static) "static"] 464 [(:inline) "inline"] 465 [(:extern) "extern"])) 466 (reverse quals)))) 467 468 (define (gen-cfn name quals args rettype body) 469 `(,@(gen-qualifiers quals) " " 470 ,(cise-render-typed-var rettype name env) 471 "(" ,(gen-args args env) ")" 472 "{",(cise-render-to-string `(begin ,@body) 'stmt)"}")) 473 ;; Another ugly hack to allow both :: rettype and ::rettype as 474 ;; return type specification. Duplication in stub.scm. 475 (define (type-symbol? s) 476 (and (keyword? s) (#/^:[^:]/ (keyword->string s)))) 477 (define (type-symbol-type s) 478 (string->symbol (string-drop (keyword->string s) 1))) 479 480 (define (gen-ret-type ret-type) 481 (match ret-type 482 [(x ...) (intersperse " " (map x->string x))] 483 [x (x->string x)])) 484 (define (record-static name quals args ret-type) 485 (cise-push-static-decl! 486 `(,(source-info form env) 487 ,@(gen-qualifiers quals) " " 488 ,(gen-ret-type ret-type)" ",(cise-render-identifier name) 489 "(",(gen-args args env)");"))) 490 491 (define (check-quals name quals args ret-type body) 492 (match body 493 [(':static . body) 494 (check-quals name `(:static ,@quals) args ret-type body)] 495 [(':inline . body) 496 (check-quals name `(:inline ,@quals) args ret-type body)] 497 [((? keyword? z) . body) 498 (errorf "Invalid qualifier in define-cfn ~s: ~s" name z)] 499 [_ 500 (case (car form) 501 [(define-cfn) 502 (when (memq :static quals) 503 (record-static name quals args ret-type)) 504 (gen-cfn name quals args ret-type body)] 505 [(declare-cfn) 506 (unless (null? body) 507 (errorf "declare-cfn ~s must not have a body" name)) 508 (when (or (memq :static quals) (memq :inline quals)) 509 (errorf "declare-cfn ~s cannot have qualifier(s)" name)) 510 (record-static name '(:extern) args ret-type) 511 ;; no function implementation 512 '()])])) 513 514 (ensure-toplevel-ctx form env) 515 (match form 516 [(_ name (args ...) ':: ret-type . body) 517 (check-quals name '() (canonicalize-argdecl args) ret-type body)] 518 [(_ name (args ...) [? type-symbol? ts] . body) 519 (check-quals name '() (canonicalize-argdecl args) (type-symbol-type ts) body)] 520 [(_ name (args ...) . body) 521 (check-quals name '() (canonicalize-argdecl args) 'ScmObj body)])) 522 523;;------------------------------------------------------------ 524;; Global variable definition and typedef 525;; 526 527;; (define-cvar <name> [::<type>] [<qualifiers>...] [<init>]) 528;; (declare-cvar <name> [::<type>]) 529;; (define-ctype <name> [::<type>]) 530 531(define-cise-macro (define-cvar form env) 532 (expand-cvar form env #t)) 533(define-cise-macro (declare-cvar form env) 534 (expand-cvar form env #f)) 535(define-cise-macro (define-ctype form env) 536 (expand-cvar form env #f)) 537 538(define (expand-cvar form env toplevel-only?) 539 (define (gen-qualifiers quals) 540 (intersperse " " 541 (map (^[qual] (ecase qual 542 [(:static) "static"] 543 [(:extern) "extern"] 544 [(:typedef) "typedef"])) 545 (reverse quals)))) 546 547 (define (gen-cvar var type quals has-init? init) 548 `(,@(gen-qualifiers quals) " " 549 ,(cise-render-typed-var type var env) 550 ,@(cond-list [has-init? `(" = ",(render-rec init (expr-env env)))]) 551 ";")) 552 553 (define (check-quals var type quals init-and-quals) 554 (match init-and-quals 555 [(':static . init-and-quals) 556 (check-quals var type `(:static ,@quals) init-and-quals)] 557 [((? keyword? z) . body) 558 (errorf "Invalid qualifier in define-cvar ~s: ~s" var z)] 559 [() 560 (case (car form) 561 [(define-cvar) (gen-cvar var type quals #f #f)] 562 [(declare-cvar) 563 (unless (null? quals) 564 (errorf "declare-cvar ~s cannot have qualifier(s)" var)) 565 (gen-cvar var type '(:extern) #f #f)] 566 [(define-ctype) 567 (unless (null? quals) 568 (errorf "define-ctype ~s cannot have qualifier(s)" var)) 569 (gen-cvar var type '(:typedef) #f #f)])] 570 [(init) 571 (if (eq? (car form) 'define-cvar) 572 (gen-cvar var type quals #t init) 573 (errorf "declare-cvar ~s cannot have initializer" var))] 574 [else 575 (errorf "Invalid syntax in ~s ~s: ~s" 576 (car form) var init-and-quals)])) 577 578 ;; We allow define-cvar only on toplevel, but declare-cvar and 579 ;; define-ctype can appear in stmts. 580 (if toplevel-only? 581 (ensure-toplevel-ctx form env) 582 (ensure-stmt-or-toplevel-ctx form env)) 583 584 (let* ([canon (car (canonicalize-vardecl (list (cdr form))))] 585 [var (car canon)] 586 [spec (cdr canon)]) 587 (receive (type init-and-quals) 588 (match spec 589 [() (values 'ScmObj '())] 590 [('::) (errorf "invalid variable decl in ~s: (~s ~s)" 591 (car form) var spec)] 592 [(':: type) (values type '())] 593 [(':: type . init-and-quals) (values type init-and-quals)] 594 [else (values 'ScmObj spec)]) 595 (check-quals var type '() init-and-quals)))) 596 597;;------------------------------------------------------------ 598;; CPS transformation 599;; 600;; (define-cproc ... 601;; ... 602;; (let1/cps resultvar expr 603;; (closevar ...) 604;; expr2 ...)) 605;; 606;; => 607;; (define-cfn tmp_cc (resultvar data::(void**)) 608;; (let* ([closevar (aref data 0)] 609;; ...) 610;; expr2 ...)) 611;; 612;; (define-cproc 613;; ... 614;; (let* ([data ...]) 615;; (set! (aref data 0) closevar) 616;; ... 617;; (Scm_VMPushCC tmp_cc data k) 618;; expr)) 619;; 620;; NB: This macro assumes the outer cproc returns one ScmObj, via 621;; SCM_RESULT. So it doesn't work well if the outer cproc is declared 622;; with some other return values. For example, if the outer cproc 623;; is supposed to have ::<void> return val, you actually should 624;; write something like the following: 625;; 626;; (define-cproc foo (args ...) ;; don't declare return type here 627;; ... 628;; (let1/cps r (Scm_VMApply1 proc x ...) 629;; [var ...] 630;; ... 631;; (return SCM_UNDEFINED))) ;; explicitly return #<undef> 632;; 633 634(define-cise-macro (let1/cps form env) 635 (match form 636 [(_ rvar expr vars . body) 637 (let* ([tmp-cc (gensym "tmp_cc_")] 638 [data (gensym "data")] 639 [closed (canonicalize-argdecl vars)] 640 [cc-env (make-env 'toplevel '())]) 641 ;; NB: We want to check the # of closed variables is smaller 642 ;; than SCM_CCONT_DATA_SIZE, but it's not available at runtime 643 ;; (and if we're cross-compiling, our runtime's value may be 644 ;; different from the target system's. 645 646 ;; KLUDGE! If we're in stub generation, cise-ambient is set up 647 ;; to alter 'return' macro. But we need the original 'return' 648 ;; macro in order to expand define-cfn. We need better mechanism 649 ;; to handle it smoothly. 650 (let1 amb (cise-ambient-copy) 651 (cise-register-macro! 'return 652 (cise-lookup-macro 'return 653 (cise-default-ambient)) 654 amb) 655 (parameterize ([cise-ambient amb]) 656 (cise-push-static-decl! 657 (cise-render-to-string 658 `(define-cfn ,tmp-cc (,rvar ,data :: void**) :static 659 ,(if (null? closed) 660 `(begin (cast void ,data) 661 ,@body) 662 `(let* ,(map-with-index 663 (^[i p] 664 `(,(car p) :: ,(cdr p) 665 (cast (,(cdr p)) (aref ,data ,i)))) 666 closed) 667 ,@body))) 668 'toplevel))) 669 (for-each cise-push-static-decl-unique! 670 (reverse (~ amb'static-decls)))) 671 672 (if (null? closed) 673 `(begin (Scm_VMPushCC ,tmp-cc NULL 0) 674 (return ,expr)) 675 `(let* ([,data :: (.array void* (,(length closed)))]) 676 ,@(map-with-index 677 (^[i p] `(set! (aref ,data ,i) (cast void* ,(car p)))) 678 closed) 679 (Scm_VMPushCC ,tmp-cc ,data ,(length closed)) 680 (return ,expr))))])) 681 682;;------------------------------------------------------------ 683;; Syntax 684;; 685 686;; [cise stmt] begin STMT ... 687;; Grouping. 688(define-cise-macro (begin form env) 689 (cond 690 [(stmt-ctx? env) 691 `("{" ,@(map (cut render-rec <> env) (cdr form)) "}")] 692 [(toplevel-ctx? env) 693 `(,@(map (cut render-rec <> env) (cdr form)))] 694 [else 695 (intersperse "," (map (cut render-rec <> env) (cdr form)))])) 696 697;; [cise stmt] let* ((VAR [:: TYPE] [INIT-EXPR]) ...) STMT ... 698;; Local variables. Because of C semantics, we only support 699;; let*-style scoping. 700;; :: TYPE can be omitted if the type of VAR is ScmObj. 701(define-cise-macro (let* form env) 702 (ensure-stmt-ctx form env) 703 (match form 704 [(_ vars . body) 705 (match (canonicalize-vardecl vars) 706 [((var . spec) ...) 707 (let1 eenv (expr-env env) 708 `(begin 709 ,@(map (^[var spec] 710 (receive (type has-init? init) 711 (match spec 712 [() (values 'ScmObj #f #f)] 713 [('::) (errorf "invalid variable decl in let* form: (~s ~s)" var spec)] 714 [(init) (values 'ScmObj #t init)] 715 [(':: type) (values type #f #f)] 716 [(':: type init) (values type #t init)]) 717 `(,(cise-render-typed-var type var env) 718 ,@(cond-list [has-init? `("=",(render-rec init eenv))]) 719 ";"))) 720 var spec) 721 ,@(map (cut render-rec <> env) body)))] 722 [_ (error "invalid variable decls in let* form:" form)])] 723 )) 724 725;; [cise stmt] if TEST-EXPR THEN-STMT [ELSE-STMT] 726;; Conditional. 727(define-cise-macro (if form env) 728 (ensure-stmt-ctx form env) 729 (let1 eenv (expr-env env) 730 (match form 731 [(_ test then) 732 `("if (",(render-rec test eenv)")" 733 "{",(render-rec then env)"}")] 734 [(_ test then else) 735 `("if (",(render-rec test eenv)")" 736 "{",(render-rec then env)"} else {" ,(render-rec else env) "}")] 737 ))) 738 739;; [cise stmt] when TEST-EXPR STMT ... 740;; [cise stmt] unless TEST-EXPR STMT ... 741(define-cise-stmt when 742 [(_ test . forms) `(if ,test (begin ,@forms))]) 743 744(define-cise-stmt unless 745 [(_ test . forms) `(if (not ,test) (begin ,@forms))]) 746 747;; [cise stmt] cond (TEST STMT ...) ... [ (else STMT ...) ] 748;; Nested if. 749(define-cise-macro (cond form env) 750 (ensure-stmt-ctx form env) 751 (let1 eenv (expr-env env) 752 (define (a-clause test rest) 753 `("(" ,(render-rec test eenv) ")" ,(render-rec `(begin ,@rest) env))) 754 (match form 755 [(_ (test . rest) ...) 756 (fold-right (^[test rest r] 757 (cond 758 [(and (null? r) (eq? test 'else)) 759 `(" else ",(render-rec `(begin ,@rest) env))] 760 [(eq? test (caadr form)) ; first form 761 `("if ",(a-clause test rest) ,@r)] 762 [else 763 `("else if" ,(a-clause test rest) ,@r)])) 764 '() test rest)] 765 ))) 766 767;; [cise stmt] case EXPR ((VAL ...) STMT ...) ... [ (else STMT ...) ] 768;; [cise stmt] case/fallthrough EXPR ((VAL ...) STMT ...) ... [ (else STMT ...) ] 769;; Expands to switch-case statement. The 'case' form does not 770;; fallthrough, while 'case/fallthrough' does. 771(define (case-generator form env fallthrough?) 772 (let1 eenv (expr-env env) 773 (match form 774 [(_ expr (literalss . clauses) ...) 775 `("switch (",(render-rec expr eenv)") {" 776 ,@(map (^[literals clause] 777 `(,@(source-info literals env) 778 ,@(if (eq? literals 'else) 779 '("default: ") 780 (map (^[literal] 781 `("case ",(render-rec literal eenv)" : ")) 782 literals)) 783 ,@(render-rec `(begin ,@clause 784 ,@(if fallthrough? '() '((break)))) 785 env) 786 ,@(cond-list [fallthrough? '("/*FALLTHROUGH*/")]))) 787 literalss clauses) 788 "}")] 789 ))) 790 791(define-cise-macro (case form env) 792 (ensure-stmt-ctx form env) 793 (case-generator form env #f)) 794 795(define-cise-macro (case/fallthrough form env) 796 (ensure-stmt-ctx form env) 797 (case-generator form env #t)) 798 799;; [cise stmt] for (START-EXPR TEST-EXPR UPDATE-EXPR) STMT ... 800;; [cise stmt] for () STMT ... 801;; Loop. 802(define-cise-macro (for form env) 803 (ensure-stmt-ctx form env) 804 (let1 eenv (expr-env env) 805 (match form 806 [(_ (start test update) . body) 807 `("for (",(render-rec start eenv)"; " 808 ,(render-rec test eenv)"; " 809 ,(render-rec update eenv)")" 810 ,(render-rec `(begin ,@body) env))] 811 [(_ () . body) 812 `("for (;;)" ,(render-rec `(begin ,@body) env))] 813 ))) 814 815;; [cise stmt] loop STMT ... 816;; Alias of (for () STMT ...) 817(define-cise-stmt loop 818 [form `(for () ,@(cdr form))]) 819 820;; [cise stmt] while TEST-EXPR STMT ... 821;; Loop. 822(define-cise-macro (while form env) 823 (ensure-stmt-ctx form env) 824 (let1 eenv (expr-env env) 825 (match form 826 [(_ test . body) 827 `("while" 828 "(",(render-rec test eenv)")" 829 ,(render-rec `(begin ,@body) env))]))) 830 831;; [cise stmt] for-each (lambda (VAR) STMT ...) EXPR 832;; EXPR must yield a list. Traverse the list, binding each element 833;; to VAR and executing STMT .... 834;; The lambda form is a fake; you don't really create a closure. 835(define-cise-macro (for-each form env) 836 (ensure-stmt-ctx form env) 837 (let ([eenv (expr-env env)] 838 [tmp (gensym "cise__")]) 839 (match form 840 [(_ ('lambda (var) . body) list-expr) 841 (env-decl-add! env `(,tmp ScmObj)) 842 `("SCM_FOR_EACH(" ,(cise-render-identifier tmp) "," 843 ,(render-rec list-expr eenv) ") {" 844 ,(if (eq? var '_) 845 (render-rec `(begin ,@body) env) 846 (render-rec `(let* ((,var :: ScmObj (SCM_CAR ,tmp))) 847 ,@body) env)) 848 "}")]))) 849 850;; [cise stmt] dolist [VAR EXPR] STMT ... 851(define-cise-macro (dolist form env) 852 (ensure-stmt-ctx form env) 853 (let1 eenv (expr-env env) 854 (match form 855 [(_ (var expr) . body) 856 `(for-each (lambda (,var) ,@body) ,expr)]))) 857 858;; [cise stmt] pair-for-each (lambda (VAR) STMT ...) EXPR 859;; Like for-each, but VAR is bound to each 'spine' cell instead of 860;; each element of the list. 861(define-cise-macro (pair-for-each form env) 862 (ensure-stmt-ctx form env) 863 (let1 eenv (expr-env env) 864 (match form 865 [(_ ('lambda (var) . body) list-expr) 866 (env-decl-add! env `(,var ScmObj)) 867 `("SCM_FOR_EACH(" ,(cise-render-identifier var) "," 868 ,(render-rec list-expr eenv) ")" 869 ,(render-rec `(begin ,@body) env) 870 )]))) 871 872;; [cise stmt] dopairs [VAR EXPR] STMT ... 873(define-cise-macro (dopairs form env) 874 (ensure-stmt-ctx form env) 875 (let1 eenv (expr-env env) 876 (match form 877 [(_ (var expr) . body) 878 `(pair-for-each (lambda (,var) ,@body) ,expr)]))) 879 880;; [cise stmt] dotimes (VAR EXPR) STMT ... 881;; EXPR must yield an integer, N. Repeat STMT ... by binding VAR from 0 882;; to (N-1). 883(define-cise-macro (dotimes form env) 884 (ensure-stmt-ctx form env) 885 (let ([eenv (expr-env env)] 886 [n (gensym "cise__")]) 887 (match form 888 [(_ (var expr) . body) 889 `(let* ((,var :: int 0) (,n :: int ,expr)) 890 (for [() (< ,var ,n) (post++ ,var)] ,@body))]))) 891 892;; [cise stmt] return [EXPR] 893;; Return statement. 894;; NB: While processing cproc body in stubs, return macro is overwritten 895;; to handle multiple value returns. See cgen-stub-cise-ambient 896;; in stub.scm. 897(define-cise-macro (return form env) 898 (ensure-stmt-ctx form env) 899 (match form 900 [(_ expr) `("return (" ,(render-rec expr (expr-env env)) ");")] 901 [(_) `("return;")])) 902 903;; [cise stmt] break 904;; [cise stmt] continue 905;; Break and continue. 906(define-cise-stmt break 907 [(_) '("break;")]) 908 909(define-cise-stmt continue 910 [(_) '("continue;")]) 911 912;; [cise stmt] label NAME 913;; [cise stmt] goto NAME 914;; Label and goto. 915;; We always add null statement after the label, so that we can place 916;; (label NAME) at the end of compound statement. 917(define-cise-stmt label 918 [(_ name) `(,(cise-render-identifier name) " :; ")]) 919 920(define-cise-stmt goto 921 [(_ name) `("goto " ,(cise-render-identifier name) ";")]) 922 923;; 924;; Preprocessor directives 925;; 926 927;; [cise toplevel/stmt] .if STRING STMT [STMT] 928;; c preprocessor directive 929(define-cise-macro (.if form env) 930 (ensure-stmt-or-toplevel-ctx form env) 931 (match form 932 [(_ condition stmt1) 933 `("\n" |#reset-line| ;make sure we start from the fresh line 934 "#if " ,(cpp-condition->string condition) "\n" |#reset-line| 935 ,(render-rec stmt1 env) "\n" 936 "#endif /* " ,(cpp-condition->string condition) " */\n" |#reset-line|)] 937 [(_ condition stmt1 stmt2) 938 `("\n" |#reset-line| ;make sure we start from the fresh line 939 "#if " ,(cpp-condition->string condition) "\n" |#reset-line| 940 ,(render-rec stmt1 env) "\n" 941 "#else /* !",(cpp-condition->string condition) " */\n" |#reset-line| 942 ,(render-rec stmt2 env) "\n" 943 "#endif /* " ,(cpp-condition->string condition) " */\n" |#reset-line|)])) 944 945;; [cise toplevel/stmt] .when STRING STMT [STMT] 946;; c preprocessor directive 947(define-cise-macro (.when form env) 948 (ensure-stmt-or-toplevel-ctx form env) 949 (match form 950 [(_ condition stmt ...) 951 `("\n" |#reset-line| ;make sure we start from the fresh line 952 "#if " ,(cpp-condition->string condition) "\n" |#reset-line| 953 ,(intersperse "\n" (map (cut render-rec <> env) stmt)) "\n" 954 "#endif /* " ,(cpp-condition->string condition) " */\n" |#reset-line|)])) 955 956;; [cise toplevel/stmt] .unless STRING STMT [STMT] 957;; c preprocessor directive 958(define-cise-macro (.unless form env) 959 (ensure-stmt-or-toplevel-ctx form env) 960 (match form 961 [(_ condition stmt ...) 962 `("\n" |#reset-line| ;make sure we start from the fresh line 963 "#if !(" ,(cpp-condition->string condition) ")\n" |#reset-line| 964 ,(intersperse "\n" (map (cut render-rec <> env) stmt)) "\n" 965 "#endif /* ! " ,(cpp-condition->string condition) " */\n" |#reset-line|)])) 966 967;; [cise toplevel/stmt] .cond CLAUSE [CLAUSE] 968;; c preprocessor if/elif/endif chain directive 969(define-cise-macro (.cond form env) 970 (ensure-stmt-or-toplevel-ctx form env) 971 (match form 972 [(_ (condition . stmts) ...) 973 `("\n#if 0 /*dummy*/\n" |#reset-line| 974 ,@(fold-right (lambda (c ss seed) 975 `(,(cond [(eq? c 'else) '("#else")] 976 [else `("#elif " ,(cpp-condition->string c))]) 977 "\n" |#reset-line| 978 ,(map (cut render-rec <> env) ss) "\n" 979 ,@seed)) 980 '("#endif\n" |#reset-line|) 981 condition stmts))])) 982 983;; [cise toplevel/stmt] .define NAME [EXPR] 984;; [cise toplevel/stmt] .define NAME (ARGS...) EXPR 985;; c preprocessor define directive 986 987;; Note that "#define abc(a,b)" (i.e. no EXPR) cannot be generated 988;; because it's ambiguous with "#define abc a(b)". 989(define-cise-macro (.define form env) 990 (ensure-stmt-or-toplevel-ctx form env) 991 (match form 992 [(_ name) `("#define " ,(x->string name) "\n" |#reset-line|)] 993 [(_ name (args ...) expr) `("#define " ,(x->string name) 994 "(" ,(intersperse "," (map x->string args)) ")" 995 " (" ,(parameterize ([cise-emit-source-line #f]) 996 (render-rec expr (expr-env env))) ")" 997 "\n" |#reset-line|)] 998 [(_ name expr) `("#define " ,(x->string name) 999 " (" ,(parameterize ([cise-emit-source-line #f]) 1000 (render-rec expr (expr-env env))) ")" 1001 "\n" |#reset-line|)])) 1002 1003;; [cise toplevel/stmt] .undef NAME 1004;; c preprocessor undefine directive 1005(define-cise-macro (.undef form env) 1006 (ensure-stmt-or-toplevel-ctx form env) 1007 (match form 1008 [(_ name) `("#undef " ,(x->string name) "\n" |#reset-line|)])) 1009 1010;; [cise toplevel/stmt] .include PATH 1011;; c preprocessor include directive 1012(define-cise-macro (.include form env) 1013 (ensure-stmt-or-toplevel-ctx form env) 1014 (match form 1015 [(_ item ...) 1016 (map (^f `("#include " 1017 ,(cond [(string? f) (write-to-string f)] 1018 [(symbol? f) (x->string f)] 1019 [else (error "bad argument to .include:" f)]) 1020 "\n" |#reset-line|)) 1021 item)] 1022 [(_ . other) (error "malformed .include:" form)])) 1023 1024(define-cise-macro |#if| .if) ;backward compat. 1025 1026;;------------------------------------------------------------ 1027;; Operators 1028;; 1029 1030;; [cise expr] + EXPR ... 1031;; [cise expr] - EXPR ... 1032;; [cise expr] * EXPR ... 1033;; [cise expr] / EXPR ... 1034;; [cise expr] % EXPR EXPR 1035;; Same as C. 1036;; 1037;; [cise expr] and EXPR ... 1038;; [cise expr] or EXPR ... 1039;; [cise expr] not EXPR 1040;; 1041;; Boolean ops. C's &&, ||, and !. 1042;; 1043;; [cise expr] logand EXPR EXPR ... 1044;; [cise expr] logior EXPR EXPR ... 1045;; [cise expr] logxor EXPR EXPR ... 1046;; [cise expr] lognot EXPR 1047;; 1048;; Bitwise ops. 1049;; 1050;; [cise expr] * EXPR 1051;; [cise expr] & EXPR 1052;; 1053;; Address ops. 1054;; 1055;; [cise expr] pre++ EXPR 1056;; [cise expr] post++ EXPR 1057;; [cise expr] pre-- EXPR 1058;; [cise expr] post-- EXPR 1059;; 1060;; pre/post increment/decrement. 1061;; 1062;; [cise expr] < EXPR EXPR 1063;; [cise expr] <= EXPR EXPR 1064;; [cise expr] > EXPR EXPR 1065;; [cise expr] >= EXPR EXPR 1066;; [cise expr] == EXPR EXPR 1067;; [cise expr] != EXPR EXPR 1068;; 1069;; comparison. 1070;; 1071;; [cise expr] << EXPR EXPR 1072;; [cise expr] >> EXPR EXPR 1073;; 1074;; shift. 1075;; 1076;; [cise expr] set! LVALUE EXPR LVALUE EXPR ... 1077;; [cise expr] = LVALUE EXPR LVALUE EXPR ... 1078;; [cise expr] += LVALUE EXPR 1079;; [cise expr] -= LVALUE EXPR 1080;; [cise expr] *= LVALUE EXPR 1081;; [cise expr] /= LVALUE EXPR 1082;; [cise expr] %= LVALUE EXPR 1083;; [cise expr] <<= LVALUE EXPR 1084;; [cise expr] >>= LVALUE EXPR 1085;; [cise expr] logand= LVALUE EXPR 1086;; [cise expr] logior= LVALUE EXPR 1087;; [cise expr] logxor= LVALUE EXPR 1088;; 1089;; assignment. 1090;; 1091;; [cise expr] -> EXPR EXPR ... 1092;; [cise expr] ref EXPR EXPR ... 1093;; 1094;; reference. (ref is C's '.') 1095;; 1096;; [cise expr] aref EXPR EXPR ... 1097;; 1098;; array reference. 1099;; 1100;; [cise expr] cast TYPE EXPR 1101;; 1102;; cast. 1103;; 1104;; [cise expr] .type TYPE 1105;; 1106;; not a C expression, but useful to place a type name (e.g. an argument 1107;; of sizeof etc.) 1108;; 1109;; [cise expr] ?: TEST-EXPR THEN-EXPR ELSE-EXPR 1110;; 1111;; conditional. 1112 1113(define-macro (define-nary op sop) 1114 `(define-cise-macro (,op form env) 1115 (let1 eenv (expr-env env) 1116 (wrap-expr 1117 (match form 1118 [(_ a) 1119 (list ,sop "("(render-rec a eenv)")")] 1120 [(_ a b) 1121 (list "("(render-rec a eenv)")",sop"("(render-rec b eenv)")")] 1122 [(_ a b . x) 1123 (list* ',op (list ',op a b) x)]) 1124 env)))) 1125 1126(define-nary + "+") 1127(define-nary - "-") 1128(define-nary * "*") 1129(define-nary / "/") 1130 1131(define-nary and "&&") 1132(define-nary or "||") 1133 1134(define-nary logior "|") 1135(define-nary logxor "^") 1136(define-nary logand "&") 1137 1138(define-macro (define-unary op sop) 1139 `(define-cise-macro (,op form env) 1140 (wrap-expr 1141 (match form 1142 [(_ a) (list ,sop "("(render-rec a (expr-env env))")")]) 1143 env))) 1144 1145(define-unary not "!") 1146(define-unary lognot "~") 1147(define-unary & "&") ; only unary op 1148 1149(define-unary pre++ "++") 1150(define-unary pre-- "--") 1151 1152(define-cise-macro inc! pre++) 1153(define-cise-macro dec! pre--) 1154 1155(define-macro (define-post-unary op sop) 1156 `(define-cise-macro (,op form env) 1157 (wrap-expr 1158 (match form 1159 [(_ a) (list "("(render-rec a (expr-env env))")" ,sop)]) 1160 env))) 1161 1162(define-post-unary post++ "++") 1163(define-post-unary post-- "--") 1164 1165(define-macro (define-binary op sop) 1166 `(define-cise-macro (,op form env) 1167 (wrap-expr 1168 (match form 1169 [(_ a b) 1170 (list "("(render-rec a (expr-env env))")",sop 1171 "("(render-rec b (expr-env env))")")]) 1172 env))) 1173 1174(define-binary % "%") 1175(define-binary < "<") 1176(define-binary <= "<=") 1177(define-binary > ">") 1178(define-binary >= ">=") 1179(define-binary == "==") 1180(define-binary != "!=") 1181(define-binary << "<<") 1182(define-binary >> ">>") 1183 1184(define-binary += "+=") 1185(define-binary -= "-=") 1186(define-binary *= "*=") 1187(define-binary /= "/=") 1188(define-binary %= "%=") 1189(define-binary <<= "<<=") 1190(define-binary >>= ">>=") 1191 1192(define-binary logior= "|=") 1193(define-binary logxor= "^=") 1194(define-binary logand= "&=") 1195 1196(define-macro (define-referencer op sop) 1197 `(define-cise-macro (,op form env) 1198 (let1 eenv (expr-env env) 1199 (wrap-expr 1200 (match form 1201 [(_ a b ...) 1202 (list "("(render-rec a eenv)")",sop 1203 (intersperse ,sop (map (cut render-rec <> eenv) b)))]) 1204 env)))) 1205 1206(define-referencer -> "->") 1207(define-referencer ref ".") 1208 1209(define-cise-macro (aref form env) 1210 (let1 eenv (expr-env env) 1211 (wrap-expr 1212 (match form 1213 [(_ a b ...) 1214 `("(",(render-rec a eenv)")" 1215 ,(append-map (^[ind] `("[",(render-rec ind eenv)"]")) b))]) 1216 env))) 1217 1218(define-cise-macro (?: form env) 1219 (let1 eenv (expr-env env) 1220 (wrap-expr 1221 (match form 1222 [(?: test then else) 1223 (list "(("(render-rec test eenv)")?(" 1224 (render-rec then eenv)"):(" 1225 (render-rec else eenv)"))")]) 1226 env))) 1227 1228(define-cise-macro (set! form env) 1229 (let1 eenv (expr-env env) 1230 (let loop ((args (cdr form)) (r '())) 1231 (match args 1232 [() (wrap-expr (intersperse "," (reverse r)) env)] 1233 [(var val . more) 1234 (loop (cddr args) 1235 `((,(render-rec var eenv) 1236 "=(",(render-rec val eenv)")") ,@r))] 1237 [_ (error "uneven args for set!:" form)])))) 1238 1239(define-cise-macro = set!) ;EXPERIMENTAL 1240 1241;; [cise expr] funcall fn-expr arg-expr ... 1242;; Generate fn-expr(arg-expr, ...) 1243;; Needed if fn-expr isn't a simple identifier. 1244(define-cise-macro (funcall form env) 1245 (let1 eenv (expr-env env) 1246 (wrap-expr 1247 `("(" ,(render-rec (cadr form) eenv) ")" 1248 "(" ,@(intersperse "," (map (cut render-rec <> eenv) (cddr form))) 1249 ")") 1250 env))) 1251 1252;;------------------------------------------------------------ 1253;; Type-related expressions 1254;; 1255 1256(define-cise-macro (cast form env) 1257 (let1 eenv (expr-env env) 1258 (wrap-expr 1259 (match form 1260 [(_ type expr) 1261 `("((",(cise-render-typed-var type "" env)")(",(render-rec expr eenv)"))")]) 1262 env))) 1263 1264(define-cise-macro (.type form env) 1265 (match form 1266 [(_ typenames ...) 1267 (when (null? typenames) 1268 (errorf "empty .type form is not allowed: ~s" form)) 1269 `(,(cise-render-typed-var typenames "" env))])) 1270 1271;;------------------------------------------------------------ 1272;; Convenience expression macros 1273;; 1274 1275;; Embed raw c code. THIS IS A KLUDGE---SHOULDN'T BE USED. 1276;; Allowing raw C code prevents higher-level analysis of cise code. 1277;; This should be regarded as a compromise until cise support full C features. 1278(define-cise-expr C: 1279 [(_ stuff) (list (x->string stuff))]) 1280 1281;; DEPRECATED: cgen-stub-cise-ambient overrides 'return' macro. 1282;; Use it instead. 1283(define-cise-expr result 1284 [(_) (error "cise: result form needs at least one value'")] 1285 [(_ e) `(set! SCM_RESULT ,e)] 1286 [(_ e0 e1) `(set! SCM_RESULT0 ,e0 SCM_RESULT1 ,e1)] 1287 [(_ e0 e1 e2) `(set! SCM_RESULT0 ,e0 SCM_RESULT1 ,e1 SCM_RESULT2 ,e2)] 1288 [(_ xs ...) `(set! 1289 ,@(concatenate 1290 (map-with-index 1291 (^[i x] `(,(string->symbol #"SCM_RESULT~i") ,x)) 1292 xs)))]) 1293 1294(define-cise-expr list 1295 [(_) '("SCM_NIL")] 1296 [(_ a) `(SCM_LIST1 ,a)] 1297 [(_ a b) `(SCM_LIST2 ,a ,b)] 1298 [(_ a b c) `(SCM_LIST3 ,a ,b ,c)] 1299 [(_ a b c d) `(SCM_LIST4 ,a ,b ,c ,d)] 1300 [(_ a b c d e) `(SCM_LIST5 ,a ,b ,c ,d ,e)] 1301 [(_ xs ...) (fold-right (cut list 'Scm_Cons <> <>) 'SCM_NIL xs)]) 1302 1303(define-cise-expr values 1304 [(_) '("Scm_Values(SCM_NIL)")] 1305 [(_ a) a] 1306 [(_ a b) `(Scm_Values2 ,a ,b)] 1307 [(_ a b c) `(Scm_Values3 ,a ,b ,c)] 1308 [(_ a b c d) `(Scm_Values4 ,a ,b ,c ,d)] 1309 [(_ a b c d e) `(Scm_Values5 ,a ,b ,c ,d ,e)] 1310 [(_ x ...) `(Scm_Values ,(fold (^[elt r] `(Scm_cons ,elt ,r)) '() x))] 1311 ) 1312;; Using quote is a convenient way to embed Scheme constant in C code. 1313(define-cise-expr quote 1314 [(_ cst) 1315 (unless (cgen-current-unit) 1316 (error "cise: quote can't be used unless cgen-current-unit is set: '" 1317 cst)) 1318 (list (cgen-cexpr (cgen-literal cst)))]) 1319 1320;;============================================================= 1321;; Other utilities 1322;; 1323 1324;; type-decl-initial? and type-decl-subsequent? are used to determine if 1325;; (sym sym2 ...) is a type spec or ordinary expression. The way 1326;; to render it differs depending on whether it is a type spec. 1327;; The reason that we have two predicates are that '*' and '&' can 1328;; appear in the operator position of a valid expression. 1329(define (type-decl-initial? sym) 1330 (or (memq sym '(const class enum struct volatile unsigned long 1331 char short int float double .array .struct .union .function)) 1332 (and (symbol? sym) 1333 (#/.[*&]$/ (symbol->string sym))))) 1334 1335(define (type-decl-subsequent? sym) 1336 (or (memq sym '(* &)) 1337 (type-decl-initial? sym))) 1338 1339(define (cise-render-typed-var typespec var env) 1340 (match typespec 1341 [('.array spec (dim ...)) 1342 `(,(cise-render-typed-var spec var env) 1343 ,@(map (^.['* "[]"] 1344 [x `("[" ,(render-rec x (expr-env env)) "]")]) 1345 dim))] 1346 [('.struct (fields ...) . rest) 1347 (render-struct-or-union "struct" #f fields rest var env)] 1348 [('.struct tag (fields ...) . rest) 1349 (render-struct-or-union "struct" tag fields rest var env)] 1350 [('.struct tag . rest) 1351 (render-struct-or-union "struct" tag #f rest var env)] 1352 [('.union (fields ...) . rest) 1353 (render-struct-or-union "union" #f fields rest var env)] 1354 [('.union tag (fields ...) . rest) 1355 (render-struct-or-union "union" tag fields rest var env)] 1356 [('.union tag . rest) 1357 (render-struct-or-union "union" tag #f rest var env)] 1358 [('.function (args ...) rettype . rest) 1359 (let1 rt (let1 vv (canonicalize-vardecl `(_ ,rettype)) 1360 (unless (null? (cdr vv)) 1361 (errorf "Invalid return type in ~s" typespec)) 1362 (caddar vv)) 1363 `(,(cise-render-typed-var rt "" env) 1364 "(" 1365 ,(if (null? rest) 1366 (cise-render-identifier var) 1367 (cise-render-typed-var rest var env)) 1368 ")" 1369 "(" 1370 ,@($ intersperse ", " 1371 $ map (^.[(arg ':: type) (cise-render-typed-var type arg env)]) 1372 $ canonicalize-vardecl args) 1373 ")"))] 1374 [(x) 1375 `(,(x->string x) " " ,(cise-render-identifier var))] 1376 [(x xs ...) 1377 `(,(x->string x) " " ,(cise-render-typed-var xs var env))] 1378 [x 1379 `(,(x->string x) " " ,(cise-render-identifier var))])) 1380 1381(define (render-struct-or-union struct/union tag fields rest var env) 1382 `(,struct/union 1383 ,@(cond-list [tag `(" " ,tag)] 1384 [fields 1385 `(" { " 1386 ,@(map (^.[(member ':: type) 1387 `(,(cise-render-typed-var type member env) 1388 "; ")]) 1389 (canonicalize-vardecl fields)) 1390 "} ")] 1391 [(not fields) '(" ")]) 1392 ,(if (null? rest) 1393 (cise-render-identifier var) 1394 (cise-render-typed-var rest var env)))) 1395 1396(define (cise-render-identifier sym) 1397 (cgen-safe-name-friendly (x->string sym))) 1398 1399;; Allow var::type as (var :: type) 1400;; and (var::type init) as (var :: type init) 1401(define (canonicalize-vardecl vardecls) 1402 (define (expand-type elt seed) 1403 (cond 1404 [(keyword? elt) ;; The case of (var ::type) 1405 (rxmatch-case (keyword->string elt) 1406 [#/^:(.+)$/ (_ t) `(:: ,(string->symbol t) ,@seed)] 1407 [else (cons elt seed)])] 1408 [(symbol? elt) 1409 (rxmatch-case (symbol->string elt) 1410 [#/^(.+)::$/ (_ v) `(,(string->symbol v) :: ,@seed)] 1411 [#/^(.+)::(.+)$/ (_ v t) 1412 `(,(string->symbol v) :: ,(string->symbol t) ,@seed)] 1413 [else (cons elt seed)])] 1414 [else (cons elt seed)])) 1415 1416 (define (err decl) (error "invalid variable declaration:" decl)) 1417 1418 (define (scan in r) 1419 (match in 1420 [() (reverse r)] 1421 [([? keyword? xx] . rest) (err xx)] 1422 [([? symbol? var] ':: type . rest) 1423 (scan rest `((,var :: ,type) ,@r))] 1424 [([? symbol? var] . rest) 1425 (scan rest `((,var :: ScmObj) ,@r))] 1426 [(([? symbol? v] [? symbol? t] . args) . rest) 1427 (scan rest `(,(expand-type v (expand-type t args)) ,@r))] 1428 [(([? symbol? vt] . args) . rest) 1429 (scan rest `(,(expand-type vt args) ,@r))] 1430 [(xx . rest) (err xx)])) 1431 1432 (scan (fold-right expand-type '() vardecls) '())) 1433 1434;; Like canonicalize-vardecl, but for argument declarations. 1435;; (foo::type bar baz:: type bee :: type) 1436;; => ((foo . type) (bar . ScmObj) (baz . type) (bee . type)) 1437(define (canonicalize-argdecl argdecls) 1438 (define (rec args) 1439 (match (canonicalize-vardecl args) 1440 [() '()] 1441 [((var ':: type) . rest) `((,var . ,type) ,@(rec rest))] 1442 [(var . rest) `((,var . ScmObj) ,@(rec rest))])) 1443 (rec argdecls)) 1444 1445;;============================================================= 1446;; Sealing the default environment 1447;; This must come at the bottom of the module. 1448 1449(cise-ambient (cise-default-ambient)) 1450 1451