~ chicken-core (master) /chicken-syntax.scm

   1;;;; chicken-syntax.scm - non-standard syntax extensions
   2;
   3; Copyright (c) 2008-2022, The CHICKEN Team
   4; Copyright (c) 2000-2007, Felix L. Winkelmann
   5; All rights reserved.
   6;
   7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
   8; conditions are met:
   9;
  10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  11;     disclaimer. 
  12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  13;     disclaimer in the documentation and/or other materials provided with the distribution. 
  14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
  15;     products derived from this software without specific prior written permission. 
  16;
  17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
  18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  25; POSSIBILITY OF SUCH DAMAGE.
  26
  27
  28(declare
  29  (unit chicken-syntax)
  30  (uses expand internal)
  31  (disable-interrupts)
  32  (fixnum) )
  33
  34;; IMPORTANT: These macros expand directly into fully qualified names
  35;; from the scrutinizer and support modules.
  36
  37#+(not debugbuild)
  38(declare
  39  (no-bound-checks)
  40  (no-procedure-checks))
  41
  42(import (scheme)
  43        (chicken base)
  44        (chicken fixnum)
  45        (chicken syntax)
  46        (chicken internal)
  47        (chicken platform))
  48
  49(include "common-declarations.scm")
  50(include "mini-srfi-1.scm")
  51
  52;;; Exceptions:
  53(set! ##sys#chicken.condition-macro-environment
  54  (let ((me0 (##sys#macro-environment)))
  55
  56(##sys#extend-macro-environment
  57 'handle-exceptions
  58 `((call-with-current-continuation . scheme#call-with-current-continuation))
  59 (##sys#er-transformer
  60  (lambda (form r c)
  61    (##sys#check-syntax 'handle-exceptions form '(_ variable _ . _))
  62    (let ((k (r 'k))
  63	  (args (r 'args)))
  64      `((,(r 'call-with-current-continuation)
  65	 (##core#lambda
  66	  (,k)
  67	  (chicken.condition#with-exception-handler
  68	   (##core#lambda (,(cadr form)) (,k (##core#lambda () ,(caddr form))))
  69	   (##core#lambda
  70	    ()
  71	    (##sys#call-with-values
  72	     (##core#lambda () ,@(cdddr form))
  73	     (##core#lambda
  74	      ,args
  75	      (,k (##core#lambda () (##sys#apply ##sys#values ,args))))))))))))))
  76
  77(##sys#extend-macro-environment
  78 'condition-case
  79 `((memv . scheme#memv))
  80 (##sys#er-transformer
  81  (lambda (form r c)
  82    (##sys#check-syntax 'condition-case form '(_ _ . _))
  83    (let ((exvar (r 'exvar))
  84	  (kvar (r 'kvar))
  85	  (%and (r 'and))
  86	  (%memv (r 'memv))
  87	  (%else (r 'else)))
  88      (define (parse-clause c)
  89	(let* ((var (and (symbol? (car c)) (car c)))
  90	       (kinds (if var (cadr c) (car c)))
  91	       (body (if var
  92			 `(##core#let ((,var ,exvar)) ,@(cddr c))
  93			 `(##core#let () ,@(cdr c)))))
  94	  (if (null? kinds)
  95	      `(,%else ,body)
  96	      `((,%and ,kvar ,@(map (lambda (k)
  97				      `(,%memv (##core#quote ,k) ,kvar)) kinds))
  98		,body))))
  99      `(,(r 'handle-exceptions) ,exvar
 100	(##core#let ((,kvar (,%and (##sys#structure? ,exvar
 101						     (##core#quote condition))
 102				   (##sys#slot ,exvar 1))))
 103		    ,(let ((clauses (map parse-clause (cddr form))))
 104		       `(,(r 'cond)
 105			 ,@clauses
 106			 ,@(if (assq %else clauses)
 107			       `()   ; Don't generate two else clauses
 108			       `((,%else (chicken.condition#signal ,exvar)))))))
 109	,(cadr form))))))
 110
 111(macro-subset me0 ##sys#default-macro-environment)))
 112
 113
 114;;; type-related syntax
 115
 116(set! ##sys#chicken.type-macro-environment
 117  (let ((me0 (##sys#macro-environment)))
 118
 119(##sys#extend-macro-environment
 120 ': '()
 121 (##sys#er-transformer
 122  (lambda (x r c)
 123    (##sys#check-syntax ': x '(_ symbol _ . _))
 124    (if (not (memq #:compiling ##sys#features))
 125	'(##core#undefined)
 126	(let* ((type1 (strip-syntax (caddr x)))
 127	       (name1 (cadr x)))
 128	  ;; we need pred/pure info, so not using
 129	  ;; "chicken.compiler.scrutinizer#check-and-validate-type"
 130	  (let-values (((type pred pure)
 131			(chicken.compiler.scrutinizer#validate-type
 132			 type1
 133			 (strip-syntax name1))))
 134	    (cond ((not type)
 135		   (##sys#syntax-error ': "invalid type syntax" name1 type1))
 136		  (else
 137		   `(##core#declare
 138		     (type (,name1 ,type1 ,@(cdddr x)))
 139		     ,@(if pure `((pure ,name1)) '())
 140		     ,@(if pred `((predicate (,name1 ,pred))) '()))))))))))
 141
 142(##sys#extend-macro-environment
 143 'the '()
 144 (##sys#er-transformer
 145  (lambda (x r c)
 146    (##sys#check-syntax 'the x '(_ _ _))
 147    (if (not (memq #:compiling ##sys#features))
 148	(caddr x)
 149	`(##core#the ,(chicken.compiler.scrutinizer#check-and-validate-type (cadr x) 'the)
 150		     #t
 151		     ,(caddr x))))))
 152
 153(##sys#extend-macro-environment
 154 'assume '()
 155 (syntax-rules ()
 156   ((_ ((var type) ...) body ...)
 157    (let ((var (the type var)) ...) body ...))))
 158
 159(##sys#extend-macro-environment
 160 'define-specialization '()
 161 (##sys#er-transformer
 162  (lambda (x r c)
 163    (cond ((not (memq #:compiling ##sys#features)) '(##core#undefined))
 164	  (else
 165	   (##sys#check-syntax 'define-specialization x '(_ (variable . #(_ 0)) _ . #(_ 0 1)))
 166	   (let* ((head (cadr x))
 167		  (name (car head))
 168		  (args (cdr head))
 169		  (alias (gensym name))
 170		  (rtypes (and (pair? (cdddr x)) (strip-syntax (caddr x))))
 171		  (%define (r 'define))
 172		  (body (if rtypes (cadddr x) (caddr x))))
 173	     (let loop ((args args) (anames '()) (atypes '()))
 174	       (cond ((null? args)
 175		      (let ((anames (reverse anames))
 176			    (atypes (reverse atypes))
 177			    (spec
 178			     `(,alias ,@(let loop2 ((anames anames) (i 1))
 179					  (if (null? anames)
 180					      '()
 181					      (cons (vector i)
 182						    (loop2 (cdr anames) (fx+ i 1))))))))
 183			`(##core#begin
 184			  (##core#local-specialization
 185			   ,name
 186			   ,alias
 187			   ,(cons atypes
 188				  (if (and rtypes (pair? rtypes))
 189				      (list
 190				       (map (cut chicken.compiler.scrutinizer#check-and-validate-type
 191					      <>
 192					      'define-specialization)
 193					    rtypes)
 194				       spec)
 195				      (list spec))))
 196			  (##core#declare (inline ,alias) (hide ,alias))
 197			  (,%define (,alias ,@anames)
 198				    (##core#let ,(map (lambda (an at)
 199							(list an `(##core#the ,at #t ,an)))
 200						      anames atypes)
 201						,body)))))
 202		     (else
 203		      (let ((arg (car args)))
 204			(cond ((symbol? arg)
 205			       (loop (cdr args) (cons arg anames) (cons '* atypes)))
 206			      ((and (list? arg) (fx= 2 (length arg)) (symbol? (car arg)))
 207			       (loop
 208				(cdr args)
 209				(cons (car arg) anames)
 210				(cons
 211				 (chicken.compiler.scrutinizer#check-and-validate-type
 212				  (cadr arg)
 213				  'define-specialization)
 214				 atypes)))
 215			      (else (##sys#syntax-error
 216				     'define-specialization
 217				     "invalid argument syntax" arg head)))))))))))))
 218
 219(##sys#extend-macro-environment
 220 'compiler-typecase '()
 221 (##sys#er-transformer
 222  (lambda (x r c)
 223    (##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 1)))
 224    (let ((val (memq #:compiling ##sys#features))
 225	  (var (gensym))
 226	  (ln (get-line-number x)))
 227      `(##core#let ((,var ,(cadr x)))
 228	 (##core#typecase
 229	  ,ln
 230	  ,var		; must be variable (see: CPS transform)
 231	  ,@(map (lambda (clause)
 232		 (let ((hd (strip-syntax (car clause))))
 233		   (list
 234		    (if (eq? hd 'else)
 235			'else
 236			(if val
 237			    (chicken.compiler.scrutinizer#check-and-validate-type
 238			     hd
 239			     'compiler-typecase)
 240			    hd))
 241		    `(##core#begin ,@(cdr clause)))))
 242		 (cddr x))))))))
 243
 244(##sys#extend-macro-environment
 245 'define-type '()
 246 (##sys#er-transformer
 247  (lambda (x r c)
 248    (##sys#check-syntax 'define-type x '(_ variable _))
 249    (cond ((not (memq #:compiling ##sys#features)) '(##core#undefined))
 250	  (else
 251	   (let ((name (strip-syntax (cadr x)))
 252		 (%quote (r 'quote))
 253		 (t0 (strip-syntax (caddr x))))
 254	     `(##core#elaborationtimeonly
 255	       (##sys#put/restore!
 256		(,%quote ,name)
 257		(,%quote ##compiler#type-abbreviation)
 258		(,%quote
 259		 ,(chicken.compiler.scrutinizer#check-and-validate-type
 260		   t0 'define-type name))))))))))
 261
 262(macro-subset me0 ##sys#default-macro-environment)))
 263
 264;;; Syntax-related syntax (for use in macro transformers)
 265
 266(set! ##sys#chicken.syntax-macro-environment
 267  (let ((me0 (##sys#macro-environment)))
 268
 269(##sys#extend-macro-environment
 270 'syntax
 271 '()
 272 (##sys#er-transformer
 273  (lambda (x r c)
 274    (##sys#check-syntax 'syntax x '(_ _))
 275    `(##core#syntax ,(cadr x)))))
 276
 277(##sys#extend-macro-environment
 278 'begin-for-syntax '()
 279 (##sys#er-transformer
 280  (lambda (x r c)
 281    (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
 282    (##sys#register-meta-expression `(##core#begin ,@(cdr x)))
 283    `(##core#elaborationtimeonly (##core#begin ,@(cdr x))))))
 284
 285(##sys#extend-macro-environment
 286 'define-for-syntax '()
 287 (##sys#er-transformer
 288  (lambda (form r c)
 289    (##sys#check-syntax 'define-for-syntax form '(_ _ . _))
 290    `(,(r 'begin-for-syntax)
 291      (,(r 'define) ,@(cdr form))))))
 292
 293
 294;;; Compiler syntax
 295
 296(##sys#extend-macro-environment
 297 'define-compiler-syntax '()
 298 (syntax-rules ()
 299   ((_ name)
 300    (##core#define-compiler-syntax name #f))
 301   ((_ name transformer)
 302    (##core#define-compiler-syntax name transformer))))
 303
 304(##sys#extend-macro-environment
 305 'let-compiler-syntax '()
 306 (syntax-rules ()
 307   ((_ (binding ...) body ...)
 308    (##core#let-compiler-syntax (binding ...) body ...))))
 309
 310(macro-subset me0 ##sys#default-macro-environment)))
 311
 312
 313;;; Non-standard macros that provide core/"base" functionality:
 314
 315(set! ##sys#chicken.base-macro-environment
 316  (let ((me0 (##sys#macro-environment)))
 317
 318(##sys#extend-macro-environment
 319 'define-constant
 320 '()
 321 (##sys#er-transformer
 322  (lambda (form r c)
 323    (##sys#check-syntax 'define-constant form '(_ variable _))
 324    `(##core#define-constant ,@(cdr form)))))
 325
 326(##sys#extend-macro-environment
 327 'define-record '()
 328 (##sys#er-transformer
 329  (lambda (x r c)
 330    (##sys#check-syntax 'define-record x '(_ variable . _))
 331    (let* ((type-name (cadr x))
 332	   (plain-name (strip-syntax type-name))
 333	   (prefix (symbol->string plain-name))
 334	   (tag (if (##sys#current-module)
 335		    (symbol-append
 336		     (##sys#module-name (##sys#current-module)) '|#| plain-name)
 337		    plain-name))
 338	   (slots (cddr x))
 339	   (%define (r 'define))
 340	   (%setter (r 'chicken.base#setter))
 341	   (%getter-with-setter (r 'chicken.base#getter-with-setter))
 342	   (slotnames
 343	    (map (lambda (slot)
 344		   (cond ((symbol? slot) slot)
 345			 ((and (pair? slot)
 346			       (c (car slot) %setter) 
 347			       (pair? (cdr slot))
 348			       (symbol? (cadr slot))
 349			       (null? (cddr slot)))
 350			  (cadr slot))
 351			 (else
 352			  (##sys#syntax-error
 353			   'define-record "invalid slot specification" slot))))
 354		 slots)))
 355      `(##core#begin
 356	(,%define ,type-name (##core#quote ,tag))
 357	(,%define 
 358	 ,(string->symbol (string-append "make-" prefix))
 359	 (##core#lambda 
 360	  ,slotnames
 361	  (##sys#make-structure (##core#quote ,tag) ,@slotnames)))
 362	(,%define
 363	 ,(string->symbol (string-append prefix "?"))
 364	 (##core#lambda (x) (##sys#structure? x (##core#quote ,tag))))
 365	,@(let mapslots ((slots slots) (i 1))
 366	    (if (eq? slots '())
 367		slots
 368		(let* ((a (car slots))
 369		       (has-setter (not (symbol? a)))
 370		       (slotname (symbol->string (if has-setter (cadr a) a)))
 371		       (setr (string->symbol (string-append prefix "-" slotname "-set!")))
 372		       (getr (string->symbol (string-append prefix "-" slotname)))
 373		       (setrcode
 374			`(##core#lambda 
 375			  (x val)
 376			  (##core#check (##sys#check-structure x (##core#quote ,tag)))
 377			  (##sys#block-set! x ,i val) ) ))
 378		  (cons
 379		   `(##core#begin
 380		     ,@(if has-setter
 381			   '()
 382			   `((,%define ,setr ,setrcode)))
 383		     (,%define
 384		      ,getr
 385		      ,(if has-setter
 386			   `(,%getter-with-setter
 387			     (##core#lambda
 388			      (x) 
 389			      (##core#check (##sys#check-structure x (##core#quote ,tag)))
 390			      (##sys#block-ref x ,i) )
 391			     ,setrcode)
 392			   `(##core#lambda 
 393			     (x)
 394			     (##core#check (##sys#check-structure x (##core#quote ,tag)))
 395			     (##sys#block-ref x ,i) ) ) ) )
 396		   (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) ) ) )
 397
 398(##sys#extend-macro-environment
 399 'receive
 400 '()
 401 (##sys#er-transformer
 402  (lambda (form r c)
 403    (##sys#check-syntax 'receive form '(_ _ . #(_ 0)))
 404    (cond ((null? (cddr form))
 405	   `(##sys#call-with-values (##core#lambda () ,@(cdr form)) ##sys#list) )
 406	  (else
 407	   (##sys#check-syntax 'receive form '(_ lambda-list _ . #(_ 1)))
 408	   (let ((vars (cadr form))
 409		 (exp (caddr form))
 410		 (rest (cdddr form)))
 411	     (if (and (pair? vars) (null? (cdr vars)))
 412		 `(##core#let ((,(car vars) ,exp)) ,@rest)
 413		 `(##sys#call-with-values 
 414		   (##core#lambda () ,exp)
 415		   (##core#lambda ,vars ,@rest)) ) ) ) ) )))
 416
 417(##sys#extend-macro-environment
 418 'declare '()
 419 (##sys#er-transformer
 420  (lambda (form r c)
 421    `(##core#declare ,@(cdr form)))))
 422
 423(##sys#extend-macro-environment
 424 'delay-force
 425 '()
 426 (##sys#er-transformer
 427  (lambda (form r c)
 428    (##sys#check-syntax 'delay-force form '(_ _))
 429    `(##sys#make-promise (##core#lambda () ,(cadr form))))))
 430
 431(##sys#extend-macro-environment
 432 'include '()
 433 (##sys#er-transformer
 434  (lambda (form r c)
 435    (##sys#check-syntax 'include form '(_ . #(string 1)))
 436    `(##core#begin ,@(map (lambda (x) `(##core#include ,x #f))
 437                       (cdr form))))))
 438
 439(##sys#extend-macro-environment
 440 'include-ci '()
 441 (##sys#er-transformer
 442  (lambda (form r c)
 443    (##sys#check-syntax 'include-ci form '(_ . #(string 1)))
 444    `(##core#begin ,@(map (lambda (x) `(##core#include-ci ,x #f))
 445                       (cdr form))))))
 446
 447(##sys#extend-macro-environment
 448 'include-relative '()
 449 (##sys#er-transformer
 450  (lambda (form r c)
 451    (##sys#check-syntax 'include-relative form '(_ . #(string 1)))
 452    `(##core#begin ,@(map (lambda (x) 
 453                            `(##core#include ,x ,##sys#current-source-filename))
 454                       (cdr form))))))
 455
 456(##sys#extend-macro-environment
 457 'fluid-let '()
 458 (##sys#er-transformer
 459  (lambda (form r c)
 460    (##sys#check-syntax 'fluid-let form '(_ #((variable _) 0) . _))
 461     (let* ((clauses (cadr form))
 462	   (body (cddr form))
 463	   (ids (##sys#map car clauses))
 464	   (new-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
 465	   (old-tmps (##sys#map (lambda (x) (r (gensym))) clauses)))
 466       `(##core#let
 467	 (,@(map ##sys#list new-tmps (##sys#map cadr clauses))
 468	  ,@(map ##sys#list old-tmps
 469		 (let loop ((n (length clauses)))
 470		   (if (eq? n 0)
 471		       '()
 472		       (cons #f (loop (fx- n 1))) ) ) ) )
 473	 (##sys#dynamic-wind
 474	  (##core#lambda ()
 475		    ,@(map (lambda (ot id) `(##core#set! ,ot ,id))
 476			   old-tmps ids)
 477		    ,@(map (lambda (id nt) `(##core#set! ,id ,nt))
 478			   ids new-tmps)
 479		    (##core#undefined) )
 480	  (##core#lambda () ,@body)
 481	  (##core#lambda ()
 482		    ,@(map (lambda (nt id) `(##core#set! ,nt ,id))
 483			   new-tmps ids)
 484		    ,@(map (lambda (id ot) `(##core#set! ,id ,ot))
 485			   ids old-tmps)
 486		    (##core#undefined) ) ) ) ) )))
 487
 488(##sys#extend-macro-environment
 489 'parameterize '()
 490 (##sys#er-transformer
 491  (lambda (form r c)
 492    (define (pname p)
 493      (if (symbol? p)
 494	  (gensym p)
 495	  (gensym "parameter")))
 496    (##sys#check-syntax 'parameterize form '#(_ 2))
 497    (let* ((bindings (cadr form))
 498	   (body (cddr form))
 499	   (convert? (r 'convert?))
 500	   (params (##sys#map car bindings))
 501	   (vals (##sys#map cadr bindings))
 502	   (param-aliases (##sys#map (lambda (z) (r (pname z))) params))
 503	   (saveds (##sys#map (lambda (z) (r (gensym 'saved))) params))
 504	   (temps (##sys#map (lambda (z) (r (gensym 'tmp))) params)) )
 505      `(##core#let
 506	,(map ##sys#list param-aliases params) ; These may be expressions
 507	(##core#let
 508	 ,(map ##sys#list saveds vals)
 509	 (##core#let
 510	  ;; Inner names are actually set.  This hides the exact
 511	  ;; ordering of the let if any call/cc is used in the
 512	  ;; value expressions (see first example in #1336).
 513	  ,(map ##sys#list saveds saveds)
 514	  (##core#let
 515	   ((,convert? (##core#the boolean #t #t))) ; Convert only first time extent is entered!
 516	   (##sys#dynamic-wind
 517	    (##core#lambda ()
 518	      (##core#let
 519	       ;; First, call converters (which may throw exceptions!)
 520	       ,(map (lambda (p s temp)
 521		       `(,temp (##core#if ,convert? (,p ,s #t #f) ,s)))
 522		     param-aliases saveds temps)
 523	       ;; Save current values so we can restore them later
 524	       ,@(map (lambda (p s) `(##core#set! ,s (,p)))
 525		      param-aliases saveds)
 526	       ;; Set parameters to their new values.  This can't fail.
 527	       ,@(map (lambda (p t) `(,p ,t #f #t)) param-aliases temps)
 528	       ;; Remember we already converted (only call converters once!)
 529	       (##core#set! ,convert? #f)))
 530	    (##core#lambda () ,@body)
 531	    (##core#lambda ()
 532	      (##core#let
 533	       ;; Remember the current value of each parameter.
 534	       ,(map (lambda (p s temp) `(,temp (,p)))
 535		     param-aliases saveds temps)
 536	       ;; Restore each parameter to its old value.
 537	       ,@(map (lambda (p s) `(,p ,s #f #t)) param-aliases saveds)
 538	       ;; Save current value for later re-invocations.
 539	       ,@(map (lambda (s temp) `(##core#set! ,s ,temp))
 540		      saveds temps))))))))))))
 541
 542(##sys#extend-macro-environment
 543 'require-library
 544 '()
 545 (##sys#er-transformer
 546  (lambda (x r c)
 547    `(##core#begin
 548      ,@(map (lambda (x)
 549	       (let-values (((name lib _ _ _ _) (##sys#decompose-import x r c 'import)))
 550		 (if (not lib)
 551		     '(##core#undefined)
 552		     `(##core#require ,lib ,name))))
 553	     (cdr x))))))
 554
 555(##sys#extend-macro-environment
 556 'when '()
 557 (##sys#er-transformer
 558  (lambda (form r c)
 559    (##sys#check-syntax 'when form '#(_ 2))
 560    `(##core#if ,(cadr form)
 561		(##core#begin ,@(cddr form))))))
 562
 563(##sys#extend-macro-environment
 564 'unless '()
 565 (##sys#er-transformer
 566  (lambda (form r c)
 567    (##sys#check-syntax 'unless form '#(_ 2))
 568    `(##core#if ,(cadr form)
 569		(##core#undefined)
 570		(##core#begin ,@(cddr form))))))
 571
 572(##sys#extend-macro-environment
 573 'set!-values '()
 574 (##sys#er-transformer
 575  (lambda (form r c)
 576    (##sys#check-syntax 'set!-values form '(_ lambda-list _))
 577    (##sys#expand-multiple-values-assignment (cadr form) (caddr form)))))
 578
 579(set! chicken.syntax#define-values-definition
 580  (##sys#extend-macro-environment
 581   'define-values '()
 582   (##sys#er-transformer
 583    (lambda (form r c)
 584      (##sys#check-syntax 'define-values form '(_ lambda-list _))
 585      `(##core#begin
 586	,@(##sys#decompose-lambda-list
 587	   (cadr form)
 588	   (lambda (vars argc rest)
 589	     (for-each (lambda (nm)
 590			 (let ((name (##sys#get nm '##core#macro-alias nm)))
 591			   (##sys#register-export name (##sys#current-module))))
 592		       vars)
 593	     (map (lambda (nm) `(##core#ensure-toplevel-definition ,nm))
 594		  vars)))
 595	,(##sys#expand-multiple-values-assignment (cadr form) (caddr form)))))))
 596
 597(##sys#extend-macro-environment
 598 'let-values '()
 599 (##sys#er-transformer
 600  (lambda (form r c)
 601    (##sys#check-syntax 'let-values form '(_ list . _))
 602    (let ((vbindings (cadr form))
 603	  (body (cddr form)))
 604      (letrec ((append* (lambda (il l)
 605			  (if (not (pair? il))
 606			      (cons il l)
 607			      (cons (car il)
 608				    (append* (cdr il) l)))))
 609	       (map* (lambda (proc l)
 610		       (cond ((null? l) '())
 611			     ((not (pair? l)) (proc l))
 612			     (else (cons (proc (car l)) (map* proc (cdr l))))))))
 613	(let* ([llists (map car vbindings)]
 614	       [vars (let loop ((llists llists) (acc '()))
 615		       (if (null? llists)
 616			   acc
 617			   (let* ((llist (car llists))
 618				  (new-acc
 619				   (cond ((list? llist) (append llist acc))
 620					 ((pair? llist) (append* llist acc))
 621					 (else (cons llist acc)))))
 622			     (loop (cdr llists) new-acc))))]
 623	       [aliases (map (lambda (v) (cons v (r (gensym v)))) vars)]
 624	       [lookup (lambda (v) (cdr (assq v aliases)))]
 625	       [llists2 (let loop ((llists llists) (acc '()))
 626			  (if (null? llists)
 627			      (reverse acc)
 628			      (let* ((llist (car llists))
 629				     (new-acc
 630				      (cond ((not (pair? llist)) (cons (lookup llist) acc))
 631					    (else (cons (map* lookup llist) acc)))))
 632				(loop (cdr llists) new-acc))))])
 633	  (let fold ([llists llists]
 634		     [exps (map (lambda (x) (cadr x)) vbindings)]
 635		     [llists2 llists2] )
 636	    (cond ((null? llists)
 637		   `(##core#let
 638		     ,(map (lambda (v) (##sys#list v (lookup v))) vars) 
 639		     ,@body) )
 640		  ((and (pair? (car llists2)) (null? (cdar llists2)))
 641		   `(##core#let
 642		     ((,(caar llists2) ,(car exps)))
 643		     ,(fold (cdr llists) (cdr exps) (cdr llists2)) ) )
 644		  (else
 645		   `(##sys#call-with-values
 646		     (##core#lambda () ,(car exps))
 647		     (##core#lambda
 648		      ,(car llists2) 
 649		      ,(fold (cdr llists) (cdr exps) (cdr llists2))) ) ) ) ) ) ) ) ) ) )
 650
 651(##sys#extend-macro-environment
 652 'let*-values '()
 653 (##sys#er-transformer
 654  (lambda (form r c)
 655    (##sys#check-syntax 'let*-values form '(_ list . _))
 656    (let ((vbindings (cadr form))
 657	  (body (cddr form))
 658	  (%let-values (r 'let-values)) )
 659      (let fold ([vbindings vbindings])
 660	(if (null? vbindings)
 661	    `(##core#let () ,@body)
 662	    `(,%let-values (,(car vbindings))
 663			   ,(fold (cdr vbindings))) ) ) ))))
 664
 665;;XXX do we need letrec*-values ?
 666(##sys#extend-macro-environment
 667 'letrec-values '()
 668 (##sys#er-transformer
 669  (lambda (form r c)
 670    (##sys#check-syntax 'letrec-values form '(_ #((lambda-list . _) 0) . _))
 671    (let ((vbindings (cadr form))
 672          (body (cddr form)))
 673      (let ((vars  (map car vbindings))
 674            (exprs (map cadr vbindings)))
 675        `(##core#let
 676          ,(map (lambda (v) (##sys#list v '(##core#undefined)))
 677                (foldl (lambda (l v) ; flatten multi-value formals
 678                         (##sys#append l (##sys#decompose-lambda-list
 679					  v (lambda (a _ _) a))))
 680                       '()
 681                       vars))
 682          ,@(map ##sys#expand-multiple-values-assignment vars exprs)
 683          ,@body))))))
 684
 685(##sys#extend-macro-environment
 686 'letrec*
 687 '()
 688 (##sys#er-transformer
 689  (lambda (x r c)
 690    (##sys#check-syntax 'letrec* x '(_ #((variable _) 0) . #(_ 1)))
 691    (check-for-multiple-bindings (cadr x) x "letrec*")
 692    `(##core#letrec* ,@(cdr x)))))
 693
 694(##sys#extend-macro-environment
 695 'nth-value 
 696 `((list-ref . scheme#list-ref))
 697 (##sys#er-transformer
 698  (lambda (form r c)
 699    (##sys#check-syntax 'nth-value form '(_ _ _))
 700    (let ((v (r 'tmp)))
 701      `(##sys#call-with-values
 702	(##core#lambda () ,(caddr form))
 703	(##core#lambda ,v (,(r 'list-ref) ,v ,(cadr form))))))))
 704
 705(##sys#extend-macro-environment
 706 'define-inline '()
 707 (##sys#er-transformer
 708  (lambda (form r c)
 709    (letrec ([quotify-proc 
 710	      (lambda (xs id)
 711		(##sys#check-syntax id xs '#(_ 1))
 712		(let* ([head (car xs)]
 713		       [name (if (pair? head) (car head) head)]
 714		       [val (if (pair? head)
 715				`(##core#lambda ,(cdr head) ,@(cdr xs))
 716				(cadr xs) ) ] )
 717		  (when (or (not (pair? val)) 
 718			    (and (not (eq? '##core#lambda (car val)))
 719				 (not (c (r 'lambda) (car val)))))
 720		    (##sys#syntax-error
 721		     'define-inline "invalid substitution form - must be lambda"
 722		     name val) )
 723		  (list name val) ) ) ] )
 724      `(##core#define-inline ,@(quotify-proc (cdr form) 'define-inline)))) ) )
 725
 726(##sys#extend-macro-environment
 727 'and-let* '()
 728 (##sys#er-transformer
 729  (lambda (form r c)
 730    (##sys#check-syntax 'and-let* form '(_ #(_ 0) . _))
 731    (let ((bindings (cadr form))
 732	  (body (cddr form)))
 733      (let fold ([bs bindings] [last #t])
 734	(if (null? bs)
 735	    `(##core#begin ,last . ,body)
 736	    (let ([b (car bs)]
 737		  [bs2 (cdr bs)] )
 738	      (cond [(not (pair? b))
 739                     (##sys#check-syntax 'and-let* b 'variable)
 740                     (let ((var (r (gensym))))
 741                       `(##core#let ((,var ,b))
 742                          (##core#if ,var ,(fold bs2 var) #f)))]
 743		    [(null? (cdr b))
 744                     (let ((var (r (gensym))))
 745                       `(##core#let ((,var ,(car b)))
 746                          (##core#if ,var ,(fold bs2 var) #f)))]
 747		    [else
 748		     (##sys#check-syntax 'and-let* b '(variable _))
 749		     (let ((var (car b)))
 750		       `(##core#let ((,var ,(cadr b)))
 751			 (##core#if ,var ,(fold bs2 var) #f)))]))))))))
 752
 753
 754
 755;;; Optional argument handling:
 756
 757;;; Copyright (C) 1996 by Olin Shivers.
 758;;;
 759;;; This file defines three macros for parsing optional arguments to procs:
 760;;; 	(LET-OPTIONALS  arg-list ((var1 default1) ...) . body)
 761;;; 	(LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
 762;;; 	(:OPTIONAL rest-arg default-exp)
 763;;;
 764;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
 765;;; explicit-renaming low-level macro system. You'll have to do some work to
 766;;; port it to another macro system.
 767;;;
 768;;; The LET-OPTIONALS* and :OPTIONAL macros are defined with simple
 769;;; high-level macros, and should be portable to any R4RS system.
 770;;;
 771;;; These macros are all careful to evaluate their default forms *only* if
 772;;; their values are needed.
 773;;;
 774;;; The only non-R4RS dependencies in the macros are ERROR 
 775;;; and CALL-WITH-VALUES.
 776;;; 	-Olin
 777
 778;;; (LET-OPTIONALS arg-list ((var1 default1) ...) 
 779;;;   body
 780;;;   ...)
 781;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 782;;; This form is for binding a procedure's optional arguments to either
 783;;; the passed-in values or a default.
 784;;;
 785;;; The expression takes a rest list ARG-LIST and binds the VARi to
 786;;; the elements of the rest list. When there are no more elements, then
 787;;; the remaining VARi are bound to their corresponding DEFAULTi values.
 788;;;
 789;;; - The default expressions are *not* evaluated unless needed.
 790;;;
 791;;; - When evaluated, the default expressions are carried out in the *outer*
 792;;;   environment. That is, the DEFAULTi forms do *not* see any of the VARi
 793;;;   bindings.
 794;;;
 795;;;   I originally wanted to have the DEFAULTi forms get eval'd in a LET*
 796;;;   style scope -- DEFAULT3 would see VAR1 and VAR2, etc. But this is
 797;;;   impossible to implement without side effects or redundant conditional
 798;;;   tests. If I drop this requirement, I can use the efficient expansion
 799;;;   shown below. If you need LET* scope, use the less-efficient 
 800;;;   LET-OPTIONALS* form defined below.
 801;;;
 802;;; Example:
 803;;; (define (read-string! str . maybe-args)
 804;;;   (let-optionals maybe-args ((port (current-input-port))
 805;;;                              (start 0)
 806;;;                              (end (string-length str)))
 807;;;     ...))
 808;;;
 809;;; expands to:
 810;;; 
 811;;; (let* ((body (lambda (port start end) ...))
 812;;;        (end-def (lambda (%port %start) (body %port %start <end-default>)))
 813;;;        (start-def (lambda (%port) (end-def %port <start-default>)))
 814;;;        (port-def  (lambda () (start-def <port-def>))))
 815;;;   (if (null? rest) (port-def)
 816;;;       (let ((%port (car rest))
 817;;; 	        (rest (cdr rest)))
 818;;; 	  (if (null? rest) (start-def %port)
 819;;; 	      (let ((%start (car rest))
 820;;; 		    (rest (cdr rest)))
 821;;; 	        (if (null? rest) (end-def %port %start)
 822;;; 		    (let ((%end (car rest))
 823;;; 			  (rest (cdr rest)))
 824;;; 		      (if (null? rest) (body %port %start %end)
 825;;; 			  (error ...)))))))))
 826
 827
 828;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
 829
 830(##sys#extend-macro-environment
 831 'let-optionals 
 832 `((null? . scheme#null?)
 833   (car . scheme#car)
 834   (cdr . scheme#cdr))
 835 (##sys#er-transformer
 836  (lambda (form r c)
 837    (##sys#check-syntax 'let-optionals form '(_ _ . _))
 838    (let ((arg-list (cadr form))
 839	  (var/defs (caddr form))
 840	  (body (cdddr form)))
 841
 842      ;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
 843      ;; I wish I had a reasonable loop macro.
 844
 845      (define (make-default-procs vars body-proc defaulter-names defs rename)
 846	(let recur ((vars (reverse vars))
 847		    (defaulter-names (reverse defaulter-names))
 848		    (defs (reverse defs))
 849		    (next-guy body-proc))
 850	  (if (null? vars) '()
 851	      (let ((vars (cdr vars)))
 852		`((,(car defaulter-names)
 853		   (##core#lambda ,(reverse vars)
 854			     (,next-guy ,@(reverse vars) ,(car defs))))
 855		  . ,(recur vars
 856			    (cdr defaulter-names)
 857			    (cdr defs)
 858			    (car defaulter-names)))))))
 859
 860
 861      ;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
 862
 863      (define (make-if-tree vars defaulters body-proc rest rename)
 864	(let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
 865	  (if (null? vars)
 866	      `(,body-proc . ,(reverse non-defaults))
 867	      (let ((v (car vars)))
 868		`(##core#if (,(r 'null?) ,rest)
 869		       (,(car defaulters) . ,(reverse non-defaults))
 870		       (##core#let ((,v (,(r 'car) ,rest)) ; we use car/cdr, because of rest-list optimization
 871			       (,rest (,(r 'cdr) ,rest)))
 872			      ,(recur (cdr vars)
 873				      (cdr defaulters)
 874				      (cons v non-defaults))))))))
 875
 876      (##sys#check-syntax 'let-optionals var/defs '#((variable _) 0))
 877      (##sys#check-syntax 'let-optionals body '#(_ 1))
 878      (let* ((vars (map car var/defs))
 879	     (prefix-sym (lambda (prefix sym)
 880			   (string->symbol (string-append prefix (symbol->string sym)))))
 881
 882	     ;; Private vars, one for each user var.
 883	     ;; We prefix the % to help keep macro-expanded code from being
 884	     ;; too confusing.
 885	     (vars2 (map (lambda (v) (r (prefix-sym "%" v)))
 886			 vars))
 887
 888	     (defs (map cadr var/defs))
 889	     (body-proc (r 'body))
 890
 891	     ;; A private var, bound to the value of the ARG-LIST expression.
 892	     (rest-var (r '_%rest))
 893
 894	     (defaulter-names (map (lambda (var) (r (prefix-sym "def-" var)))
 895				   vars))
 896
 897	     (defaulters (make-default-procs vars2 body-proc
 898					     defaulter-names defs gensym))
 899	     (if-tree (make-if-tree vars2 defaulter-names body-proc
 900				    rest-var gensym)))
 901
 902	`(,(r 'let*) ((,rest-var ,arg-list)
 903		      (,body-proc (##core#lambda ,vars . ,body))
 904		      . ,defaulters)
 905	  ,if-tree) ) ))))
 906
 907
 908;;; (optional rest-arg default-exp)
 909;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 910;;; This form is for evaluating optional arguments and their defaults
 911;;; in simple procedures that take a *single* optional argument. It is
 912;;; a macro so that the default will not be computed unless it is needed.
 913;;; 
 914;;; REST-ARG is a rest list from a lambda -- e.g., R in
 915;;;     (lambda (a b . r) ...)
 916;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
 917;;; - If REST-ARG has 1 element, return that element.
 918
 919(##sys#extend-macro-environment
 920 'optional 
 921 `((null? . scheme#null?)
 922   (car . scheme#car)
 923   (cdr . scheme#cdr) )
 924 (##sys#er-transformer
 925  (lambda (form r c)
 926    (##sys#check-syntax 'optional form '(_ _ . #(_ 0 1)))
 927    (let ((var (r 'tmp)))
 928      `(##core#let ((,var ,(cadr form)))
 929	(##core#if (,(r 'null?) ,var) 
 930		   ,(optional (cddr form) #f)
 931		   (,(r 'car) ,var)))))))
 932
 933
 934;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
 935;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 936;;; This is just like LET-OPTIONALS, except that the DEFAULTi forms
 937;;; are evaluated in a LET*-style environment. That is, DEFAULT3 is evaluated
 938;;; within the scope of VAR1 and VAR2, and so forth.
 939;;;
 940;;; - If the last form in the ((var1 default1) ...) list is not a 
 941;;;   (VARi DEFAULTi) pair, but a simple variable REST, then it is
 942;;;   bound to any left-over values. For example, if we have VAR1 through
 943;;;   VAR7, and ARGS has 9 values, then REST will be bound to the list of
 944;;;   the two values of ARGS. If ARGS is too short, causing defaults to
 945;;;   be used, then REST is bound to '().
 946
 947(##sys#extend-macro-environment
 948 'let-optionals* 
 949 `((null? . scheme#null?)
 950   (car . scheme#car)
 951   (cdr . scheme#cdr))
 952 (##sys#er-transformer
 953  (lambda (form r c)
 954    (##sys#check-syntax 'let-optionals* form '(_ _ list . _))
 955    (let ((args (cadr form))
 956	  (var/defs (caddr form))
 957	  (body (cdddr form))
 958	  (%null? (r 'null?))
 959	  (%car (r 'car))
 960	  (%cdr (r 'cdr)))
 961      (let ((rvar (r 'tmp)))
 962	`(##core#let
 963	  ((,rvar ,args))
 964	  ,(let loop ((args rvar) (vardefs var/defs))
 965	     (if (null? vardefs)
 966		 `(##core#let () ,@body)
 967		 (let ((head (car vardefs)))
 968		   (if (pair? head)
 969		       (let ((rvar2 (r 'tmp2)))
 970			 `(##core#let ((,(car head) (##core#if (,%null? ,args)
 971							       ,(cadr head)
 972							       (,%car ,args)))
 973				       (,rvar2 (##core#if (,%null? ,args) 
 974							  (##core#quote ())
 975							  (,%cdr ,args))) )
 976				      ,(loop rvar2 (cdr vardefs)) ) )
 977		       `(##core#let ((,head ,args)) ,@body) ) ) ) ) ) ) ))))
 978
 979;;; SRFI-9:
 980
 981(##sys#extend-macro-environment
 982 'define-record-type
 983 `()
 984 (##sys#er-transformer
 985  (lambda (form r c)
 986    (##sys#check-syntax 
 987     'define-record-type 
 988     form
 989     '(_ variable #(variable 1) variable . _)) 
 990    (let* ((type-name (cadr form))
 991	   (plain-name (strip-syntax type-name))
 992	   (tag (if (##sys#current-module)
 993		    (symbol-append
 994		     (##sys#module-name (##sys#current-module))
 995		     '|#| plain-name)
 996		    plain-name))
 997	   (conser (caddr form))
 998	   (pred (cadddr form))
 999	   (slots (cddddr form))
 1000	   (%define (r 'define))
1001           (%vector (r 'vector))
1002           (%let (r 'let))
1003           (%tagvar (r 'tag))
1004	   (%getter-with-setter (r 'chicken.base#getter-with-setter))
1005	   (vars (cdr conser))
1006	   (x (r 'x))
1007	   (y (r 'y))
1008	   (slotnames (map car slots)))
1009      ;; Check for inconsistencies in slot names vs constructor args
1010      (for-each (lambda (vname)
1011		  (unless (memq vname slotnames)
1012		    (##sys#syntax-error
1013		     'define-record-type
1014		     "unknown slot name in constructor definition"
1015		     vname)))
1016		vars)
1017      `(##core#begin
1018	(,%define ,type-name (,%vector (##core#quote ,tag)))
1019	(,%define ,(car conser)
1020           (,%let ((,%tagvar ,type-name))
1021                  (##core#lambda ,(cdr conser)
1022                                 (##sys#make-structure 
1023                                                       ,%tagvar
1024                                                       ,@(map (lambda (sname)
1025                                                                (if (memq sname vars)
1026                                                                    sname
1027                                                                    '(##core#undefined) ) )
1028                                                           slotnames) ) ) ))
1029	(,%define ,pred
1030           (,%let ((,%tagvar ,type-name))
1031                  (##core#lambda (,x)
1032                                 (##sys#structure? ,x ,%tagvar))))
1033	,@(let loop ((slots slots) (i 1))
1034	    (if (null? slots)
1035		'()
1036		(let* ((slot (car slots))
1037		       (settable (pair? (cddr slot))) 
1038		       (setr (and settable (caddr slot)))
1039		       (ssetter (and (pair? setr)
1040				     (pair? (cdr setr))
1041				     (c 'setter (car setr))
1042				     (cadr setr)))
1043		       (get `(##core#lambda 
1044			      (,x)
1045			      (##core#check
1046			       (##sys#check-structure
1047				,x
1048				,%tagvar
1049				(##core#quote ,(cadr slot))))
1050			      (##sys#block-ref ,x ,i) ) )
1051		       (set (and settable
1052				 `(##core#lambda
1053				   (,x ,y)
1054				   (##core#check
1055				    (##sys#check-structure
1056				     ,x
1057				     ,%tagvar
1058				     (##core#quote ,ssetter)))
1059				   (##sys#block-set! ,x ,i ,y)) )))
1060		  `((,%define
1061		     ,(cadr slot)
1062                     (,%let ((,%tagvar ,type-name))
1063                            ,(if (and ssetter (c ssetter (cadr slot)))
1064                                 `(,%getter-with-setter ,get ,set)
1065                                 get)))
1066		    ,@(if settable
1067			  (if ssetter
1068			      (if (not (c ssetter (cadr slot)))
1069				  `((,%let ((,%tagvar ,type-name))
1070                                       ((##sys#setter ##sys#setter) ,ssetter ,set)))
1071				  '())
1072			      `((,%define ,setr (,%let ((,%tagvar ,type-name)) ,set))))
1073			  '())
1074		    ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) ) )
1075
1076
1077;;; SRFI-26:
1078
1079(##sys#extend-macro-environment
1080 'cut 
1081 `((apply . scheme#apply))
1082 (##sys#er-transformer
1083  (lambda (form r c)
1084    (let ((%<> (r '<>))
1085	  (%<...> (r '<...>))
1086	  (%apply (r 'apply)))
1087      (when (null? (cdr form))
1088        (##sys#syntax-error 'cut "you need to supply at least a procedure" form))
1089      (let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f])
1090	(if (null? xs)
1091	    (let ([rvars (reverse vars)]
1092		  [rvals (reverse vals)] )
1093	      (if rest
1094		  (let ([rv (r (gensym))])
1095		    `(##core#lambda
1096		      (,@rvars . ,rv)
1097		      (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) )
1098		  ;;XXX should we drop the begin?
1099		  `(##core#lambda ,rvars ((##core#begin ,(car rvals)) ,@(cdr rvals)) ) ) )
1100	    (cond ((c %<> (car xs))
1101		   (let ([v (r (gensym))])
1102		     (loop (cdr xs) (cons v vars) (cons v vals) #f) ) )
1103		  ((c %<...> (car xs))
1104		   (if (null? (cdr xs))
1105		       (loop '() vars vals #t)
1106		       (##sys#syntax-error
1107			'cut
1108			"tail patterns after <...> are not supported"
1109			form)))
1110		  (else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) )))
1111
1112(##sys#extend-macro-environment
1113 'cute 
1114 `((apply . scheme#apply))
1115 (##sys#er-transformer
1116  (lambda (form r c)
1117    (let ((%apply (r 'apply))
1118	  (%<> (r '<>))
1119	  (%<...> (r '<...>)))
1120      (when (null? (cdr form))
1121        (##sys#syntax-error 'cute "you need to supply at least a procedure" form))
1122      (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
1123	(if (null? xs)
1124	    (let ([rvars (reverse vars)]
1125		  [rvals (reverse vals)] )
1126	      (if rest
1127		  (let ([rv (r (gensym))])
1128		    `(##core#let 
1129		      ,bs
1130		      (##core#lambda (,@rvars . ,rv)
1131				(,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) )
1132		  `(##core#let ,bs
1133			  (##core#lambda ,rvars (,(car rvals) ,@(cdr rvals)) ) ) ) )
1134	    (cond ((c %<> (car xs))
1135		   (let ([v (r (gensym))])
1136		     (loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) )
1137		  ((c %<...> (car xs))
1138		   (if (null? (cdr xs))
1139		       (loop '() vars bs vals #t)
1140		       (##sys#syntax-error
1141			'cute
1142			"tail patterns after <...> are not supported"
1143			form)))
1144		  (else 
1145		   (let ([v (r (gensym))])
1146		     (loop (cdr xs) 
1147			   vars
1148			   (cons (list v (car xs)) bs)
1149			   (cons v vals) #f) ) ))))))))
1150
1151
1152;;; SRFI-31
1153
1154(##sys#extend-macro-environment
1155 'rec '()
1156 (##sys#er-transformer
1157  (lambda (form r c)
1158    (##sys#check-syntax 'rec form '(_ _ . _))
1159    (let ((head (cadr form)))
1160      (if (pair? head)
1161	  `(##core#letrec* ((,(car head) 
1162			     (##core#lambda ,(cdr head)
1163					    ,@(cddr form))))
1164			   ,(car head))
1165	  `(##core#letrec* ((,head ,@(cddr form))) ,head))))))
1166
1167
1168;;; SRFI-55
1169
1170(##sys#extend-macro-environment
1171 'require-extension
1172 '()
1173 (##sys#er-transformer
1174  (lambda (x r c)
1175    `(,(r 'import) ,@(cdr x)))))
1176
1177
1178;;; Assertions
1179
1180(##sys#extend-macro-environment
1181 'assert '()
1182 (##sys#er-transformer
1183  (let ((string-append string-append))
1184    (lambda (form r c)
1185      (##sys#check-syntax 'assert form '#(_ 1))
1186      (let* ((exp (cadr form))
1187	     (msg-and-args (cddr form))
1188	     (msg (optional msg-and-args "assertion failed"))
1189	     (tmp (r 'tmp)))
1190	(when (string? msg)
1191	  (and-let* ((ln (get-line-number form)))
1192	    (set! msg (string-append "(" ln ") " msg))))
1193	`(##core#let ((,tmp ,exp))
1194	   (##core#if (##core#check ,tmp)
1195		      ,tmp
1196		      (##sys#error
1197		       ,msg
1198		       ,@(if (pair? msg-and-args)
1199			     (cdr msg-and-args)
1200			     `((##core#quote ,(strip-syntax exp))))))))))))
1201
1202;; R7RS guard & guard-aux copied verbatim from the draft.
1203(##sys#extend-macro-environment
1204  'guard '()
1205  (##sys#er-transformer
1206    (lambda (form r c)
1207      (let ((%=> (r '=>))
1208            (%else (r 'else))
1209            (%begin (r 'begin))
1210            (%let (r 'let))
1211            (%if (r 'if))
1212            (%or (r 'or))
1213            (%var (r 'var))
1214            (%apply (r 'apply))
1215            (%values (r 'values))
1216            (%condition (r 'condition))
1217            (%call-with-values (r 'call-with-values))
1218            (%guard-k (r 'guard-k))
1219            (%handler-k (r 'handler-k))
1220            (%lambda (r 'lambda)))
1221        (##sys#check-syntax 'guard form '(_ (variable . #(_ 1)) . #(_ 1)))
1222        (let ((var (caadr form))
1223              (clauses (cdadr form))
1224              (es (cddr form)))
1225          (define (guard-aux reraise body more)
1226            (cond ((and (pair? body) (c %else (car body))
1227                        (null? more))
1228                   `(,%begin ,@(cdr body)))
1229                  ((and (pair? body) (pair? (cdr body)) (pair? (cddr body))
1230                        (c %=> (cadr body)))
1231                   (let ((%temp (r 'temp)))
1232                     `(,%let ((,%temp ,(car body)))
1233                             (,%if ,%temp 
1234                                   (,(caddr body) ,%temp)
1235                                   ,(if (null? more)
1236                                        reraise
1237                                        (guard-aux reraise (car more) (cdr more)))))))
1238                  ((and (pair? body) (null? (cdr body)))
1239                   (if (null? more)
1240                       `(,%or ,(car body) ,reraise)
1241                       (let ((%temp (r 'temp)))
1242                         `(,%let ((,%temp ,(car body)))
1243                                 (,%if ,%temp
1244                                       ,%temp
1245                                       ,(guard-aux reraise (car more) (cdr more)))))))
1246                  ((and (pair? body) (pair? (cdr body)))
1247                   `(,%if ,(car body)
1248                          (,%begin ,@(cdr body))
1249                          ,(if (null? more)
1250                               reraise
1251                               (guard-aux reraise (car more) (cdr more)))))))
1252          `((scheme#call-with-current-continuation
1253              (,%lambda (,%guard-k)
1254                (scheme#with-exception-handler
1255                  (,%lambda (,%condition)
1256                    ((scheme#call-with-current-continuation
1257                       (,%lambda (,%handler-k)
1258                         (,%guard-k
1259                           (,%lambda ()
1260                             (,%let ((,var ,%condition))
1261                                ,(guard-aux
1262                                  `(,%handler-k
1263                                     (,%lambda ()
1264                                       (scheme#raise-continuable ,%condition)))
1265                                   (car clauses) (cdr clauses)))))))))
1266                  (,%lambda ()
1267                    (scheme#call-with-values
1268                      (,%lambda () ,@es)
1269                      (,%lambda args
1270                        (,%guard-k
1271                           (,%lambda ()
1272                              (,%apply ,%values args)))))))))))))))
1273
1274(macro-subset me0 ##sys#default-macro-environment)))
1275
1276
1277;;; "time"
1278
1279(set! ##sys#chicken.time-macro-environment
1280  (let ((me0 (##sys#macro-environment)))
1281
1282(##sys#extend-macro-environment
1283 'time '()
1284 (##sys#er-transformer
1285  (lambda (form r c)
1286    (let ((rvar (r 't)))
1287      `(##core#begin
1288	(##sys#start-timer)
1289	(##sys#call-with-values
1290	 (##core#lambda () ,@(cdr form))
1291	 (##core#lambda
1292	  ,rvar
1293	  (##sys#display-times (##sys#stop-timer))
1294	  (##sys#apply ##sys#values ,rvar))))))))
1295
1296(macro-subset me0 ##sys#default-macro-environment)))
1297
1298;;; case-lambda (SRFI-16):
1299
1300(set! ##sys#scheme.case-lambda-macro-environment
1301  (let ((me0 (##sys#macro-environment)))
1302
1303(##sys#extend-macro-environment
1304 'case-lambda 
1305 `((>= . scheme#>=)
1306   (car . scheme#car)
1307   (cdr . scheme#cdr)
1308   (eq? . scheme#eq?)
1309   (length . scheme#length))
1310 (##sys#er-transformer
1311  (lambda (form r c)
1312    (##sys#check-syntax 'case-lambda form '(_ . _))
1313    (define (genvars n)
1314      (let loop ([i 0])
1315	(if (fx>= i n)
1316	    '()
1317	    (cons (r (gensym)) (loop (fx+ i 1))) ) ) )
1318    (let* ((mincount (apply min (map (lambda (c)
1319				       (##sys#decompose-lambda-list 
1320					(car c)
1321					(lambda (vars argc rest) argc) ) )
1322				     (cdr form))))
1323	   (minvars (genvars mincount))
1324	   (rvar (r 'rvar))
1325	   (lvar (r 'lvar))
1326	   (%>= (r '>=))
1327	   (%eq? (r 'eq?))
1328	   (%car (r 'car))
1329	   (%cdr (r 'cdr))
1330	   (%length (r 'length)))
1331      `(##core#lambda
1332	,(append minvars rvar)
1333	(##core#let
1334        ((,lvar (,%length ,rvar)))
1335	 ,(foldr
1336	   (lambda (c body)
1337	     (##sys#decompose-lambda-list
1338	      (car c)
1339	      (lambda (vars argc rest)
1340		(##sys#check-syntax 'case-lambda (car c) 'lambda-list)
1341		`(##core#if ,(let ((a2 (fx- argc mincount)))
1342			       (if rest
1343				   (if (zero? a2)
1344				       #t
1345				       `(,%>= ,lvar ,a2) )
1346				   `(,%eq? ,lvar ,a2) ) )
1347			    ,(receive (vars1 vars2)
1348				 (split-at (take vars argc) mincount)
1349			       (let ((bindings
1350				      (let build ((vars2 vars2) (vrest rvar))
1351					(if (null? vars2)
1352					    (cond (rest `(##core#let ((,rest ,vrest)) ,@(cdr c)))
1353						  ((null? (cddr c)) (cadr c))
1354						  (else `(##core#let () ,@(cdr c))) )
1355					    (let ((vrest2 (r (gensym))))
1356					      `(##core#let ((,(car vars2) (,%car ,vrest))
1357							    (,vrest2 (,%cdr ,vrest)) )
1358							   ,(if (pair? (cdr vars2))
1359								(build (cdr vars2) vrest2)
1360								(build '() vrest2) ) ) ) ) ) ) )
1361				 (if (null? vars1)
1362				     bindings
1363				     `(##core#let ,(map list vars1 minvars) ,bindings) ) ) )
1364			    ,body) ) ) )
1365	   '(##core#check (##sys#error (##core#immutable (##core#quote "no matching clause in call to 'case-lambda' form"))))
1366	   (cdr form))))))))
1367
1368(macro-subset me0 ##sys#default-macro-environment)))
1369
1370;; register features
1371
1372(register-feature! 'srfi-2 'srfi-8 'srfi-9 'srfi-11 'srfi-15 'srfi-16 'srfi-26 'srfi-31 'srfi-55)