~ chicken-core (chicken-5) /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		   (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 (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			  (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))
 436    `(##core#include ,(cadr form) #f))))
 437
 438(##sys#extend-macro-environment
 439 'include-relative '()
 440 (##sys#er-transformer
 441  (lambda (form r c)
 442    (##sys#check-syntax 'include-relative form '(_ string))
 443    `(##core#include ,(cadr form) ,##sys#current-source-filename))))
 444
 445(##sys#extend-macro-environment
 446 'fluid-let '()
 447 (##sys#er-transformer
 448  (lambda (form r c)
 449    (##sys#check-syntax 'fluid-let form '(_ #((variable _) 0) . _))
 450     (let* ((clauses (cadr form))
 451	   (body (cddr form))
 452	   (ids (##sys#map car clauses))
 453	   (new-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
 454	   (old-tmps (##sys#map (lambda (x) (r (gensym))) clauses)))
 455       `(##core#let
 456	 (,@(map ##sys#list new-tmps (##sys#map cadr clauses))
 457	  ,@(map ##sys#list old-tmps
 458		 (let loop ((n (length clauses)))
 459		   (if (eq? n 0)
 460		       '()
 461		       (cons #f (loop (fx- n 1))) ) ) ) )
 462	 (##sys#dynamic-wind
 463	  (##core#lambda ()
 464		    ,@(map (lambda (ot id) `(##core#set! ,ot ,id))
 465			   old-tmps ids)
 466		    ,@(map (lambda (id nt) `(##core#set! ,id ,nt))
 467			   ids new-tmps)
 468		    (##core#undefined) )
 469	  (##core#lambda () ,@body)
 470	  (##core#lambda ()
 471		    ,@(map (lambda (nt id) `(##core#set! ,nt ,id))
 472			   new-tmps ids)
 473		    ,@(map (lambda (id ot) `(##core#set! ,id ,ot))
 474			   ids old-tmps)
 475		    (##core#undefined) ) ) ) ) )))
 476
 477(##sys#extend-macro-environment
 478 'parameterize '()
 479 (##sys#er-transformer
 480  (lambda (form r c)
 481    (define (pname p)
 482      (if (symbol? p)
 483	  (gensym p)
 484	  (gensym "parameter")))
 485    (##sys#check-syntax 'parameterize form '#(_ 2))
 486    (let* ((bindings (cadr form))
 487	   (body (cddr form))
 488	   (convert? (r 'convert?))
 489	   (params (##sys#map car bindings))
 490	   (vals (##sys#map cadr bindings))
 491	   (param-aliases (##sys#map (lambda (z) (r (pname z))) params))
 492	   (saveds (##sys#map (lambda (z) (r (gensym 'saved))) params))
 493	   (temps (##sys#map (lambda (z) (r (gensym 'tmp))) params)) )
 494      `(##core#let
 495	,(map ##sys#list param-aliases params) ; These may be expressions
 496	(##core#let
 497	 ,(map ##sys#list saveds vals)
 498	 (##core#let
 499	  ;; Inner names are actually set.  This hides the exact
 500	  ;; ordering of the let if any call/cc is used in the
 501	  ;; value expressions (see first example in #1336).
 502	  ,(map ##sys#list saveds saveds)
 503	  (##core#let
 504	   ((,convert? (##core#the boolean #t #t))) ; Convert only first time extent is entered!
 505	   (##sys#dynamic-wind
 506	    (##core#lambda ()
 507	      (##core#let
 508	       ;; First, call converters (which may throw exceptions!)
 509	       ,(map (lambda (p s temp)
 510		       `(,temp (##core#if ,convert? (,p ,s #t #f) ,s)))
 511		     param-aliases saveds temps)
 512	       ;; Save current values so we can restore them later
 513	       ,@(map (lambda (p s) `(##core#set! ,s (,p)))
 514		      param-aliases saveds)
 515	       ;; Set parameters to their new values.  This can't fail.
 516	       ,@(map (lambda (p t) `(,p ,t #f #t)) param-aliases temps)
 517	       ;; Remember we already converted (only call converters once!)
 518	       (##core#set! ,convert? #f)))
 519	    (##core#lambda () ,@body)
 520	    (##core#lambda ()
 521	      (##core#let
 522	       ;; Remember the current value of each parameter.
 523	       ,(map (lambda (p s temp) `(,temp (,p)))
 524		     param-aliases saveds temps)
 525	       ;; Restore each parameter to its old value.
 526	       ,@(map (lambda (p s) `(,p ,s #f #t)) param-aliases saveds)
 527	       ;; Save current value for later re-invocations.
 528	       ,@(map (lambda (s temp) `(##core#set! ,s ,temp))
 529		      saveds temps))))))))))))
 530
 531(##sys#extend-macro-environment
 532 'require-library
 533 '()
 534 (##sys#er-transformer
 535  (lambda (x r c)
 536    `(##core#begin
 537      ,@(map (lambda (x)
 538	       (let-values (((name lib _ _ _ _) (##sys#decompose-import x r c 'import)))
 539		 (if (not lib)
 540		     '(##core#undefined)
 541		     `(##core#require ,lib ,name))))
 542	     (cdr x))))))
 543
 544(##sys#extend-macro-environment
 545 'when '()
 546 (##sys#er-transformer
 547  (lambda (form r c)
 548    (##sys#check-syntax 'when form '#(_ 2))
 549    `(##core#if ,(cadr form)
 550		(##core#begin ,@(cddr form))))))
 551
 552(##sys#extend-macro-environment
 553 'unless '()
 554 (##sys#er-transformer
 555  (lambda (form r c)
 556    (##sys#check-syntax 'unless form '#(_ 2))
 557    `(##core#if ,(cadr form)
 558		(##core#undefined)
 559		(##core#begin ,@(cddr form))))))
 560
 561(##sys#extend-macro-environment
 562 'set!-values '()
 563 (##sys#er-transformer
 564  (lambda (form r c)
 565    (##sys#check-syntax 'set!-values form '(_ lambda-list _))
 566    (##sys#expand-multiple-values-assignment (cadr form) (caddr form)))))
 567
 568(set! chicken.syntax#define-values-definition
 569  (##sys#extend-macro-environment
 570   'define-values '()
 571   (##sys#er-transformer
 572    (lambda (form r c)
 573      (##sys#check-syntax 'define-values form '(_ lambda-list _))
 574      `(##core#begin
 575	,@(##sys#decompose-lambda-list
 576	   (cadr form)
 577	   (lambda (vars argc rest)
 578	     (for-each (lambda (nm)
 579			 (let ((name (##sys#get nm '##core#macro-alias nm)))
 580			   (##sys#register-export name (##sys#current-module))))
 581		       vars)
 582	     (map (lambda (nm) `(##core#ensure-toplevel-definition ,nm))
 583		  vars)))
 584	,(##sys#expand-multiple-values-assignment (cadr form) (caddr form)))))))
 585
 586(##sys#extend-macro-environment
 587 'let-values '()
 588 (##sys#er-transformer
 589  (lambda (form r c)
 590    (##sys#check-syntax 'let-values form '(_ list . _))
 591    (let ((vbindings (cadr form))
 592	  (body (cddr form)))
 593      (letrec ((append* (lambda (il l)
 594			  (if (not (pair? il))
 595			      (cons il l)
 596			      (cons (car il)
 597				    (append* (cdr il) l)))))
 598	       (map* (lambda (proc l)
 599		       (cond ((null? l) '())
 600			     ((not (pair? l)) (proc l))
 601			     (else (cons (proc (car l)) (map* proc (cdr l))))))))
 602	(let* ([llists (map car vbindings)]
 603	       [vars (let loop ((llists llists) (acc '()))
 604		       (if (null? llists)
 605			   acc
 606			   (let* ((llist (car llists))
 607				  (new-acc
 608				   (cond ((list? llist) (append llist acc))
 609					 ((pair? llist) (append* llist acc))
 610					 (else (cons llist acc)))))
 611			     (loop (cdr llists) new-acc))))]
 612	       [aliases (map (lambda (v) (cons v (r (gensym v)))) vars)]
 613	       [lookup (lambda (v) (cdr (assq v aliases)))]
 614	       [llists2 (let loop ((llists llists) (acc '()))
 615			  (if (null? llists)
 616			      (reverse acc)
 617			      (let* ((llist (car llists))
 618				     (new-acc
 619				      (cond ((not (pair? llist)) (cons (lookup llist) acc))
 620					    (else (cons (map* lookup llist) acc)))))
 621				(loop (cdr llists) new-acc))))])
 622	  (let fold ([llists llists]
 623		     [exps (map (lambda (x) (cadr x)) vbindings)]
 624		     [llists2 llists2] )
 625	    (cond ((null? llists)
 626		   `(##core#let
 627		     ,(map (lambda (v) (##sys#list v (lookup v))) vars) 
 628		     ,@body) )
 629		  ((and (pair? (car llists2)) (null? (cdar llists2)))
 630		   `(##core#let
 631		     ((,(caar llists2) ,(car exps)))
 632		     ,(fold (cdr llists) (cdr exps) (cdr llists2)) ) )
 633		  (else
 634		   `(##sys#call-with-values
 635		     (##core#lambda () ,(car exps))
 636		     (##core#lambda
 637		      ,(car llists2) 
 638		      ,(fold (cdr llists) (cdr exps) (cdr llists2))) ) ) ) ) ) ) ) ) ) )
 639
 640(##sys#extend-macro-environment
 641 'let*-values '()
 642 (##sys#er-transformer
 643  (lambda (form r c)
 644    (##sys#check-syntax 'let*-values form '(_ list . _))
 645    (let ((vbindings (cadr form))
 646	  (body (cddr form))
 647	  (%let-values (r 'let-values)) )
 648      (let fold ([vbindings vbindings])
 649	(if (null? vbindings)
 650	    `(##core#let () ,@body)
 651	    `(,%let-values (,(car vbindings))
 652			   ,(fold (cdr vbindings))) ) ) ))))
 653
 654;;XXX do we need letrec*-values ?
 655(##sys#extend-macro-environment
 656 'letrec-values '()
 657 (##sys#er-transformer
 658  (lambda (form r c)
 659    (##sys#check-syntax 'letrec-values form '(_ #((lambda-list . _) 0) . _))
 660    (let ((vbindings (cadr form))
 661          (body (cddr form)))
 662      (let ((vars  (map car vbindings))
 663            (exprs (map cadr vbindings)))
 664        `(##core#let
 665          ,(map (lambda (v) (##sys#list v '(##core#undefined)))
 666                (foldl (lambda (l v) ; flatten multi-value formals
 667                         (##sys#append l (##sys#decompose-lambda-list
 668					  v (lambda (a _ _) a))))
 669                       '()
 670                       vars))
 671          ,@(map ##sys#expand-multiple-values-assignment vars exprs)
 672          ,@body))))))
 673
 674(##sys#extend-macro-environment
 675 'letrec*
 676 '()
 677 (##sys#er-transformer
 678  (lambda (x r c)
 679    (##sys#check-syntax 'letrec* x '(_ #((variable _) 0) . #(_ 1)))
 680    (check-for-multiple-bindings (cadr x) x "letrec*")
 681    `(##core#letrec* ,@(cdr x)))))
 682
 683(##sys#extend-macro-environment
 684 'nth-value 
 685 `((list-ref . scheme#list-ref))
 686 (##sys#er-transformer
 687  (lambda (form r c)
 688    (##sys#check-syntax 'nth-value form '(_ _ _))
 689    (let ((v (r 'tmp)))
 690      `(##sys#call-with-values
 691	(##core#lambda () ,(caddr form))
 692	(##core#lambda ,v (,(r 'list-ref) ,v ,(cadr form))))))))
 693
 694(##sys#extend-macro-environment
 695 'define-inline '()
 696 (##sys#er-transformer
 697  (lambda (form r c)
 698    (letrec ([quotify-proc 
 699	      (lambda (xs id)
 700		(##sys#check-syntax id xs '#(_ 1))
 701		(let* ([head (car xs)]
 702		       [name (if (pair? head) (car head) head)]
 703		       [val (if (pair? head)
 704				`(##core#lambda ,(cdr head) ,@(cdr xs))
 705				(cadr xs) ) ] )
 706		  (when (or (not (pair? val)) 
 707			    (and (not (eq? '##core#lambda (car val)))
 708				 (not (c (r 'lambda) (car val)))))
 709		    (syntax-error
 710		     'define-inline "invalid substitution form - must be lambda"
 711		     name val) )
 712		  (list name val) ) ) ] )
 713      `(##core#define-inline ,@(quotify-proc (cdr form) 'define-inline)))) ) )
 714
 715(##sys#extend-macro-environment
 716 'and-let* '()
 717 (##sys#er-transformer
 718  (lambda (form r c)
 719    (##sys#check-syntax 'and-let* form '(_ #(_ 0) . _))
 720    (let ((bindings (cadr form))
 721	  (body (cddr form)))
 722      (let fold ([bs bindings] [last #t])
 723	(if (null? bs)
 724	    `(##core#begin ,last . ,body)
 725	    (let ([b (car bs)]
 726		  [bs2 (cdr bs)] )
 727	      (cond [(not (pair? b))
 728                     (##sys#check-syntax 'and-let* b 'variable)
 729                     (let ((var (r (gensym))))
 730                       `(##core#let ((,var ,b))
 731                          (##core#if ,var ,(fold bs2 var) #f)))]
 732		    [(null? (cdr b))
 733                     (let ((var (r (gensym))))
 734                       `(##core#let ((,var ,(car b)))
 735                          (##core#if ,var ,(fold bs2 var) #f)))]
 736		    [else
 737		     (##sys#check-syntax 'and-let* b '(variable _))
 738		     (let ((var (car b)))
 739		       `(##core#let ((,var ,(cadr b)))
 740			 (##core#if ,var ,(fold bs2 var) #f)))]))))))))
 741
 742
 743
 744;;; Optional argument handling:
 745
 746;;; Copyright (C) 1996 by Olin Shivers.
 747;;;
 748;;; This file defines three macros for parsing optional arguments to procs:
 749;;; 	(LET-OPTIONALS  arg-list ((var1 default1) ...) . body)
 750;;; 	(LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
 751;;; 	(:OPTIONAL rest-arg default-exp)
 752;;;
 753;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
 754;;; explicit-renaming low-level macro system. You'll have to do some work to
 755;;; port it to another macro system.
 756;;;
 757;;; The LET-OPTIONALS* and :OPTIONAL macros are defined with simple
 758;;; high-level macros, and should be portable to any R4RS system.
 759;;;
 760;;; These macros are all careful to evaluate their default forms *only* if
 761;;; their values are needed.
 762;;;
 763;;; The only non-R4RS dependencies in the macros are ERROR 
 764;;; and CALL-WITH-VALUES.
 765;;; 	-Olin
 766
 767;;; (LET-OPTIONALS arg-list ((var1 default1) ...) 
 768;;;   body
 769;;;   ...)
 770;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 771;;; This form is for binding a procedure's optional arguments to either
 772;;; the passed-in values or a default.
 773;;;
 774;;; The expression takes a rest list ARG-LIST and binds the VARi to
 775;;; the elements of the rest list. When there are no more elements, then
 776;;; the remaining VARi are bound to their corresponding DEFAULTi values.
 777;;;
 778;;; - The default expressions are *not* evaluated unless needed.
 779;;;
 780;;; - When evaluated, the default expressions are carried out in the *outer*
 781;;;   environment. That is, the DEFAULTi forms do *not* see any of the VARi
 782;;;   bindings.
 783;;;
 784;;;   I originally wanted to have the DEFAULTi forms get eval'd in a LET*
 785;;;   style scope -- DEFAULT3 would see VAR1 and VAR2, etc. But this is
 786;;;   impossible to implement without side effects or redundant conditional
 787;;;   tests. If I drop this requirement, I can use the efficient expansion
 788;;;   shown below. If you need LET* scope, use the less-efficient 
 789;;;   LET-OPTIONALS* form defined below.
 790;;;
 791;;; Example:
 792;;; (define (read-string! str . maybe-args)
 793;;;   (let-optionals maybe-args ((port (current-input-port))
 794;;;                              (start 0)
 795;;;                              (end (string-length str)))
 796;;;     ...))
 797;;;
 798;;; expands to:
 799;;; 
 800;;; (let* ((body (lambda (port start end) ...))
 801;;;        (end-def (lambda (%port %start) (body %port %start <end-default>)))
 802;;;        (start-def (lambda (%port) (end-def %port <start-default>)))
 803;;;        (port-def  (lambda () (start-def <port-def>))))
 804;;;   (if (null? rest) (port-def)
 805;;;       (let ((%port (car rest))
 806;;; 	        (rest (cdr rest)))
 807;;; 	  (if (null? rest) (start-def %port)
 808;;; 	      (let ((%start (car rest))
 809;;; 		    (rest (cdr rest)))
 810;;; 	        (if (null? rest) (end-def %port %start)
 811;;; 		    (let ((%end (car rest))
 812;;; 			  (rest (cdr rest)))
 813;;; 		      (if (null? rest) (body %port %start %end)
 814;;; 			  (error ...)))))))))
 815
 816
 817;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
 818
 819(##sys#extend-macro-environment
 820 'let-optionals 
 821 `((null? . scheme#null?)
 822   (car . scheme#car)
 823   (cdr . scheme#cdr))
 824 (##sys#er-transformer
 825  (lambda (form r c)
 826    (##sys#check-syntax 'let-optionals form '(_ _ . _))
 827    (let ((arg-list (cadr form))
 828	  (var/defs (caddr form))
 829	  (body (cdddr form)))
 830
 831      ;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
 832      ;; I wish I had a reasonable loop macro.
 833
 834      (define (make-default-procs vars body-proc defaulter-names defs rename)
 835	(let recur ((vars (reverse vars))
 836		    (defaulter-names (reverse defaulter-names))
 837		    (defs (reverse defs))
 838		    (next-guy body-proc))
 839	  (if (null? vars) '()
 840	      (let ((vars (cdr vars)))
 841		`((,(car defaulter-names)
 842		   (##core#lambda ,(reverse vars)
 843			     (,next-guy ,@(reverse vars) ,(car defs))))
 844		  . ,(recur vars
 845			    (cdr defaulter-names)
 846			    (cdr defs)
 847			    (car defaulter-names)))))))
 848
 849
 850      ;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
 851
 852      (define (make-if-tree vars defaulters body-proc rest rename)
 853	(let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
 854	  (if (null? vars)
 855	      `(,body-proc . ,(reverse non-defaults))
 856	      (let ((v (car vars)))
 857		`(##core#if (,(r 'null?) ,rest)
 858		       (,(car defaulters) . ,(reverse non-defaults))
 859		       (##core#let ((,v (,(r 'car) ,rest)) ; we use car/cdr, because of rest-list optimization
 860			       (,rest (,(r 'cdr) ,rest)))
 861			      ,(recur (cdr vars)
 862				      (cdr defaulters)
 863				      (cons v non-defaults))))))))
 864
 865      (##sys#check-syntax 'let-optionals var/defs '#((variable _) 0))
 866      (##sys#check-syntax 'let-optionals body '#(_ 1))
 867      (let* ((vars (map car var/defs))
 868	     (prefix-sym (lambda (prefix sym)
 869			   (string->symbol (string-append prefix (symbol->string sym)))))
 870
 871	     ;; Private vars, one for each user var.
 872	     ;; We prefix the % to help keep macro-expanded code from being
 873	     ;; too confusing.
 874	     (vars2 (map (lambda (v) (r (prefix-sym "%" v)))
 875			 vars))
 876
 877	     (defs (map cadr var/defs))
 878	     (body-proc (r 'body))
 879
 880	     ;; A private var, bound to the value of the ARG-LIST expression.
 881	     (rest-var (r '_%rest))
 882
 883	     (defaulter-names (map (lambda (var) (r (prefix-sym "def-" var)))
 884				   vars))
 885
 886	     (defaulters (make-default-procs vars2 body-proc
 887					     defaulter-names defs gensym))
 888	     (if-tree (make-if-tree vars2 defaulter-names body-proc
 889				    rest-var gensym)))
 890
 891	`(,(r 'let*) ((,rest-var ,arg-list)
 892		      (,body-proc (##core#lambda ,vars . ,body))
 893		      . ,defaulters)
 894	  ,if-tree) ) ))))
 895
 896
 897;;; (optional rest-arg default-exp)
 898;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 899;;; This form is for evaluating optional arguments and their defaults
 900;;; in simple procedures that take a *single* optional argument. It is
 901;;; a macro so that the default will not be computed unless it is needed.
 902;;; 
 903;;; REST-ARG is a rest list from a lambda -- e.g., R in
 904;;;     (lambda (a b . r) ...)
 905;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
 906;;; - If REST-ARG has 1 element, return that element.
 907
 908(##sys#extend-macro-environment
 909 'optional 
 910 `((null? . scheme#null?)
 911   (car . scheme#car)
 912   (cdr . scheme#cdr) )
 913 (##sys#er-transformer
 914  (lambda (form r c)
 915    (##sys#check-syntax 'optional form '(_ _ . #(_ 0 1)))
 916    (let ((var (r 'tmp)))
 917      `(##core#let ((,var ,(cadr form)))
 918	(##core#if (,(r 'null?) ,var) 
 919		   ,(optional (cddr form) #f)
 920		   (,(r 'car) ,var)))))))
 921
 922
 923;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
 924;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 925;;; This is just like LET-OPTIONALS, except that the DEFAULTi forms
 926;;; are evaluated in a LET*-style environment. That is, DEFAULT3 is evaluated
 927;;; within the scope of VAR1 and VAR2, and so forth.
 928;;;
 929;;; - If the last form in the ((var1 default1) ...) list is not a 
 930;;;   (VARi DEFAULTi) pair, but a simple variable REST, then it is
 931;;;   bound to any left-over values. For example, if we have VAR1 through
 932;;;   VAR7, and ARGS has 9 values, then REST will be bound to the list of
 933;;;   the two values of ARGS. If ARGS is too short, causing defaults to
 934;;;   be used, then REST is bound to '().
 935
 936(##sys#extend-macro-environment
 937 'let-optionals* 
 938 `((null? . scheme#null?)
 939   (car . scheme#car)
 940   (cdr . scheme#cdr))
 941 (##sys#er-transformer
 942  (lambda (form r c)
 943    (##sys#check-syntax 'let-optionals* form '(_ _ list . _))
 944    (let ((args (cadr form))
 945	  (var/defs (caddr form))
 946	  (body (cdddr form))
 947	  (%null? (r 'null?))
 948	  (%car (r 'car))
 949	  (%cdr (r 'cdr)))
 950      (let ((rvar (r 'tmp)))
 951	`(##core#let
 952	  ((,rvar ,args))
 953	  ,(let loop ((args rvar) (vardefs var/defs))
 954	     (if (null? vardefs)
 955		 `(##core#let () ,@body)
 956		 (let ((head (car vardefs)))
 957		   (if (pair? head)
 958		       (let ((rvar2 (r 'tmp2)))
 959			 `(##core#let ((,(car head) (##core#if (,%null? ,args)
 960							       ,(cadr head)
 961							       (,%car ,args)))
 962				       (,rvar2 (##core#if (,%null? ,args) 
 963							  (##core#quote ())
 964							  (,%cdr ,args))) )
 965				      ,(loop rvar2 (cdr vardefs)) ) )
 966		       `(##core#let ((,head ,args)) ,@body) ) ) ) ) ) ) ))))
 967
 968
 969;;; case-lambda (SRFI-16):
 970
 971(##sys#extend-macro-environment
 972 'case-lambda 
 973 `((>= . scheme#>=)
 974   (car . scheme#car)
 975   (cdr . scheme#cdr)
 976   (eq? . scheme#eq?)
 977   (length . scheme#length))
 978 (##sys#er-transformer
 979  (lambda (form r c)
 980    (##sys#check-syntax 'case-lambda form '(_ . _))
 981    (define (genvars n)
 982      (let loop ([i 0])
 983	(if (fx>= i n)
 984	    '()
 985	    (cons (r (gensym)) (loop (fx+ i 1))) ) ) )
 986    (let* ((mincount (apply min (map (lambda (c)
 987				       (##sys#decompose-lambda-list 
 988					(car c)
 989					(lambda (vars argc rest) argc) ) )
 990				     (cdr form))))
 991	   (minvars (genvars mincount))
 992	   (rvar (r 'rvar))
 993	   (lvar (r 'lvar))
 994	   (%>= (r '>=))
 995	   (%eq? (r 'eq?))
 996	   (%car (r 'car))
 997	   (%cdr (r 'cdr))
 998	   (%length (r 'length)))
 999      `(##core#lambda
 1000	,(append minvars rvar)
1001	(##core#let
1002        ((,lvar (,%length ,rvar)))
1003	 ,(foldr
1004	   (lambda (c body)
1005	     (##sys#decompose-lambda-list
1006	      (car c)
1007	      (lambda (vars argc rest)
1008		(##sys#check-syntax 'case-lambda (car c) 'lambda-list)
1009		`(##core#if ,(let ((a2 (fx- argc mincount)))
1010			       (if rest
1011				   (if (zero? a2)
1012				       #t
1013				       `(,%>= ,lvar ,a2) )
1014				   `(,%eq? ,lvar ,a2) ) )
1015			    ,(receive (vars1 vars2)
1016				 (split-at (take vars argc) mincount)
1017			       (let ((bindings
1018				      (let build ((vars2 vars2) (vrest rvar))
1019					(if (null? vars2)
1020					    (cond (rest `(##core#let ((,rest ,vrest)) ,@(cdr c)))
1021						  ((null? (cddr c)) (cadr c))
1022						  (else `(##core#let () ,@(cdr c))) )
1023					    (let ((vrest2 (r (gensym))))
1024					      `(##core#let ((,(car vars2) (,%car ,vrest))
1025							    (,vrest2 (,%cdr ,vrest)) )
1026							   ,(if (pair? (cdr vars2))
1027								(build (cdr vars2) vrest2)
1028								(build '() vrest2) ) ) ) ) ) ) )
1029				 (if (null? vars1)
1030				     bindings
1031				     `(##core#let ,(map list vars1 minvars) ,bindings) ) ) )
1032			    ,body) ) ) )
1033	   '(##core#check (##sys#error (##core#immutable (##core#quote "no matching clause in call to 'case-lambda' form"))))
1034	   (cdr form))))))))
1035
1036
1037;;; Record printing:
1038
1039(##sys#extend-macro-environment
1040 'define-record-printer '() ;; DEPRECATED
1041 (##sys#er-transformer
1042  (lambda (form r c)
1043    (##sys#check-syntax 'define-record-printer form '(_ _ . _))
1044    (let ((head (cadr form))
1045	  (body (cddr form))
1046	  (%set-record-printer! (r 'chicken.base#set-record-printer!)))
1047      (cond [(pair? head)
1048	     (##sys#check-syntax 
1049	      'define-record-printer (cons head body)
1050	      '((variable variable variable) . #(_ 1)))
1051	     (let* ((plain-name (strip-syntax (##sys#slot head 0)))
1052		    (tag (if (##sys#current-module)
1053			     (symbol-append
1054			      (##sys#module-name (##sys#current-module))
1055			      '|#| plain-name)
1056			     plain-name)))
1057	       `(,%set-record-printer!
1058		 (##core#quote ,tag)
1059		 (##core#lambda ,(##sys#slot head 1) ,@body)))]
1060	    (else
1061	     (##sys#check-syntax 'define-record-printer (cons head body) '(variable _))
1062	     (let* ((plain-name (strip-syntax head))
1063		    (tag (if (##sys#current-module)
1064			     (symbol-append
1065			      (##sys#module-name (##sys#current-module))
1066			      '|#| plain-name)
1067			     plain-name)))
1068	       `(,%set-record-printer!
1069		 (##core#quote ,tag) ,@body))))))))
1070
1071;;; SRFI-9:
1072
1073(##sys#extend-macro-environment
1074 'define-record-type
1075 `()
1076 (##sys#er-transformer
1077  (lambda (form r c)
1078    (##sys#check-syntax 
1079     'define-record-type 
1080     form
1081     '(_ variable #(variable 1) variable . _)) 
1082    (let* ((type-name (cadr form))
1083	   (plain-name (strip-syntax type-name))
1084	   (tag (if (##sys#current-module)
1085		    (symbol-append
1086		     (##sys#module-name (##sys#current-module))
1087		     '|#| plain-name)
1088		    plain-name))
1089	   (conser (caddr form))
1090	   (pred (cadddr form))
1091	   (slots (cddddr form))
1092	   (%define (r 'define))
1093	   (%getter-with-setter (r 'chicken.base#getter-with-setter))
1094	   (vars (cdr conser))
1095	   (x (r 'x))
1096	   (y (r 'y))
1097	   (slotnames (map car slots)))
1098      ;; Check for inconsistencies in slot names vs constructor args
1099      (for-each (lambda (vname)
1100		  (unless (memq vname slotnames)
1101		    (syntax-error
1102		     'define-record-type
1103		     "unknown slot name in constructor definition"
1104		     vname)))
1105		vars)
1106      `(##core#begin
1107	;; TODO: Maybe wrap this in an opaque object?
1108	(,%define ,type-name (##core#quote ,tag))
1109	(,%define ,conser
1110		  (##sys#make-structure 
1111		   (##core#quote ,tag)
1112		   ,@(map (lambda (sname)
1113			    (if (memq sname vars)
1114				sname
1115				'(##core#undefined) ) )
1116			  slotnames) ) )
1117	(,%define (,pred ,x) (##sys#structure? ,x (##core#quote ,tag)))
1118	,@(let loop ([slots slots] [i 1])
1119	    (if (null? slots)
1120		'()
1121		(let* ((slot (car slots))
1122		       (settable (pair? (cddr slot))) 
1123		       (setr (and settable (caddr slot)))
1124		       (ssetter (and (pair? setr)
1125				     (pair? (cdr setr))
1126				     (c 'setter (car setr))
1127				     (cadr setr)))
1128		       (get `(##core#lambda 
1129			      (,x)
1130			      (##core#check
1131			       (##sys#check-structure
1132				,x
1133				(##core#quote ,tag)
1134				(##core#quote ,(cadr slot))))
1135			      (##sys#block-ref ,x ,i) ) )
1136		       (set (and settable
1137				 `(##core#lambda
1138				   (,x ,y)
1139				   (##core#check
1140				    (##sys#check-structure
1141				     ,x
1142				     (##core#quote ,tag)
1143				     (##core#quote ,ssetter)))
1144				   (##sys#block-set! ,x ,i ,y)) )))
1145		  `((,%define
1146		     ,(cadr slot) 
1147		     ,(if (and ssetter (c ssetter (cadr slot)))
1148			  `(,%getter-with-setter ,get ,set)
1149			  get))
1150		    ,@(if settable
1151			  (if ssetter
1152			      (if (not (c ssetter (cadr slot)))
1153				  `(((##sys#setter ##sys#setter) ,ssetter ,set))
1154				  '())
1155			      `((,%define ,setr ,set)))
1156			  '())
1157		    ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) ) )
1158
1159
1160;;; SRFI-26:
1161
1162(##sys#extend-macro-environment
1163 'cut 
1164 `((apply . scheme#apply))
1165 (##sys#er-transformer
1166  (lambda (form r c)
1167    (let ((%<> (r '<>))
1168	  (%<...> (r '<...>))
1169	  (%apply (r 'apply)))
1170      (when (null? (cdr form))
1171        (syntax-error 'cut "you need to supply at least a procedure" form))
1172      (let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f])
1173	(if (null? xs)
1174	    (let ([rvars (reverse vars)]
1175		  [rvals (reverse vals)] )
1176	      (if rest
1177		  (let ([rv (r (gensym))])
1178		    `(##core#lambda
1179		      (,@rvars . ,rv)
1180		      (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) )
1181		  ;;XXX should we drop the begin?
1182		  `(##core#lambda ,rvars ((##core#begin ,(car rvals)) ,@(cdr rvals)) ) ) )
1183	    (cond ((c %<> (car xs))
1184		   (let ([v (r (gensym))])
1185		     (loop (cdr xs) (cons v vars) (cons v vals) #f) ) )
1186		  ((c %<...> (car xs))
1187		   (if (null? (cdr xs))
1188		       (loop '() vars vals #t)
1189		       (syntax-error
1190			'cut
1191			"tail patterns after <...> are not supported"
1192			form)))
1193		  (else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) )))
1194
1195(##sys#extend-macro-environment
1196 'cute 
1197 `((apply . scheme#apply))
1198 (##sys#er-transformer
1199  (lambda (form r c)
1200    (let ((%apply (r 'apply))
1201	  (%<> (r '<>))
1202	  (%<...> (r '<...>)))
1203      (when (null? (cdr form))
1204        (syntax-error 'cute "you need to supply at least a procedure" form))
1205      (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
1206	(if (null? xs)
1207	    (let ([rvars (reverse vars)]
1208		  [rvals (reverse vals)] )
1209	      (if rest
1210		  (let ([rv (r (gensym))])
1211		    `(##core#let 
1212		      ,bs
1213		      (##core#lambda (,@rvars . ,rv)
1214				(,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) )
1215		  `(##core#let ,bs
1216			  (##core#lambda ,rvars (,(car rvals) ,@(cdr rvals)) ) ) ) )
1217	    (cond ((c %<> (car xs))
1218		   (let ([v (r (gensym))])
1219		     (loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) )
1220		  ((c %<...> (car xs))
1221		   (if (null? (cdr xs))
1222		       (loop '() vars bs vals #t)
1223		       (syntax-error
1224			'cute
1225			"tail patterns after <...> are not supported"
1226			form)))
1227		  (else 
1228		   (let ([v (r (gensym))])
1229		     (loop (cdr xs) 
1230			   vars
1231			   (cons (list v (car xs)) bs)
1232			   (cons v vals) #f) ) ))))))))
1233
1234
1235;;; SRFI-31
1236
1237(##sys#extend-macro-environment
1238 'rec '()
1239 (##sys#er-transformer
1240  (lambda (form r c)
1241    (##sys#check-syntax 'rec form '(_ _ . _))
1242    (let ((head (cadr form)))
1243      (if (pair? head)
1244	  `(##core#letrec* ((,(car head) 
1245			     (##core#lambda ,(cdr head)
1246					    ,@(cddr form))))
1247			   ,(car head))
1248	  `(##core#letrec* ((,head ,@(cddr form))) ,head))))))
1249
1250
1251;;; SRFI-55
1252
1253(##sys#extend-macro-environment
1254 'require-extension
1255 '()
1256 (##sys#er-transformer
1257  (lambda (x r c)
1258    `(,(r 'import) ,@(cdr x)))))
1259
1260
1261;;; Assertions
1262
1263(##sys#extend-macro-environment
1264 'assert '()
1265 (##sys#er-transformer
1266  (let ((string-append string-append))
1267    (lambda (form r c)
1268      (##sys#check-syntax 'assert form '#(_ 1))
1269      (let* ((exp (cadr form))
1270	     (msg-and-args (cddr form))
1271	     (msg (optional msg-and-args "assertion failed"))
1272	     (tmp (r 'tmp)))
1273	(when (string? msg)
1274	  (and-let* ((ln (get-line-number form)))
1275	    (set! msg (string-append "(" ln ") " msg))))
1276	`(##core#let ((,tmp ,exp))
1277	   (##core#if (##core#check ,tmp)
1278		      ,tmp
1279		      (##sys#error
1280		       ,msg
1281		       ,@(if (pair? msg-and-args)
1282			     (cdr msg-and-args)
1283			     `((##core#quote ,(strip-syntax exp))))))))))))
1284
1285(macro-subset me0 ##sys#default-macro-environment)))
1286
1287
1288;;; "time"
1289
1290(set! ##sys#chicken.time-macro-environment
1291  (let ((me0 (##sys#macro-environment)))
1292
1293(##sys#extend-macro-environment
1294 'time '()
1295 (##sys#er-transformer
1296  (lambda (form r c)
1297    (let ((rvar (r 't)))
1298      `(##core#begin
1299	(##sys#start-timer)
1300	(##sys#call-with-values
1301	 (##core#lambda () ,@(cdr form))
1302	 (##core#lambda
1303	  ,rvar
1304	  (##sys#display-times (##sys#stop-timer))
1305	  (##sys#apply ##sys#values ,rvar))))))))
1306
1307(macro-subset me0 ##sys#default-macro-environment)))
1308
1309;; register features
1310
1311(register-feature! 'srfi-2 'srfi-8 'srfi-9 'srfi-11 'srfi-15 'srfi-16 'srfi-26 'srfi-31 'srfi-55)