source: project/r6rs-libraries/r6rs-libraries-base.scm @ 7011

Last change on this file since 7011 was 7011, checked in by felix winkelmann, 12 years ago

bug fix

File size: 97.5 KB
Line 
1;;;; simple-macros.scm
2
3
4(declare
5 (compress-literals 10)
6 (fixnum)
7 (disable-interrupts)
8 (uses srfi-1)
9 (export 
10  |library#scheme://srfi-72|
11  kffd:load-library
12  |library#chicken://chicken-internals|
13   |library#scheme://chicken|
14    macroexpand
15  identifier?
16  kffd:ensure-library
17  make-capturing-identifier
18  literal-identifier=?
19  free-identifier=?
20  bound-identifier=?
21  datum->syntax-object
22  syntax-object->datum
23  syntax-debug
24  syntax-error
25  kffd:every? 
26  kffd:uncompress-envs
27  kffd:install
28  kffd:*phase*
29  kffd:*environments*
30  kffd:*loaded-libraries*
31  kffd:embedded-syntax-lookup
32  kffd:expand
33  kffd:set-syntax!
34  kffd:for-syntax
35  kffd:scan-let
36  kffd:*current-renamer*
37  kffd:*current-library-name*
38  kffd:register-transformer
39  kffd:make-meta-renaming-procedure
40  kffd:make-library
41  kffd:register-primitive-library
42  kffd:import!
43  kffd:symbol->prefix-string
44  ##compiler#literal-compression-threshold
45  ##sys#compiler-toplevel-macroexpand-hook
46  ##sys#interpreter-toplevel-macroexpand-hook) )
47
48(define (sym->str s) 
49  (##sys#check-symbol s 'sym->str)
50  (##sys#slot s 1) )
51
52(define str->sym string->symbol)
53
54(define (kffd:symbol->prefix-string s)
55  (if (keyword? s)
56      (string-append (keyword->string s) ":")
57      (symbol->string s)))
58
59(define generate-id
60  (let ([count 0])
61    (lambda (#!optional         
62             (name (gensym)))  ;; AvT - broke line so DrScheme editor will not get confused with brackets.
63      (set! count (+ count 1))
64      (let ((x (str->sym
65                (string-append
66                 (cond [(symbol? name) (sym->str name)]
67                       [(string? name) name]
68                       [else ""] )
69                 "$$"
70                 (kffd:*current-library-name*)
71                 (number->string (##sys#fudge 2))
72                 (number->string count)))))
73        x) ) ) )
74
75
76;;;===============================================================================
77;;;
78;;; Portable Hygienic Macros and Libraries:
79;;;
80;;;   Copyright (c) 2005 Andre van Tonder
81;;;
82;;;   Permission is hereby granted, free of charge, to any person obtaining a
83;;;   copy of this software and associated documentation files (the ``Software''),
84;;;   to deal in the Software without restriction, including without limitation
85;;;   the rights to use, copy, modify, merge, publish, distribute, sublicense,
86;;;   and/or sell copies of the Software, and to permit persons to whom the
87;;;   Software is furnished to do so, subject to the following conditions:
88;;;
89;;;   The above copyright notice and this permission notice shall be included in
90;;;   all copies or substantial portions of the Software.
91;;;
92;;;   THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS
93;;;   OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
94;;;   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
95;;;   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
96;;;   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
97;;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
98;;;   DEALINGS IN THE SOFTWARE.
99;;;
100;;;===============================================================================
101
102
103
104;;;=====================================================================
105;;;
106;;; Gensym:
107;;;
108;;;=====================================================================
109
110;; For separate compilation, this should be redone to generate a
111;; globally unique symbol. 
112;; It is essential for our purposes that symbols generated by gensym
113;; not lose their separateness when converted to strings, and that
114;; two gensyms that are equal as strings be treated as equivalent
115;; identifiers by eval.  For example, the native Chez gensym fails
116;; the former and the native MzScheme gensym fails the latter.
117
118;(define gensym                           
119;  (let ((count 0))
120;    (lambda maybe-prefix-string
121;      (set! count (+ 1 count))
122;      (string->symbol
123;       (string-append (if (null? maybe-prefix-string)
124;                          ""
125;                          (car maybe-prefix-string))
126;                      "#"
127;                      (number->string count))))))
128
129
130;;;=====================================================================
131;;;
132;;; Miscellaneous utilities:
133;;;
134;;;=====================================================================
135
136(define (sexp-map f s)
137  (cond ((null? s) '())
138        ((pair? s) (cons (sexp-map f (car s))
139                         (sexp-map f (cdr s))))
140        ((vector? s)
141         (apply vector (sexp-map f (vector->list s))))
142        (else (f s))))
143
144(define (dotted-member? x ls =)
145  (cond ((null? ls) #f)
146        ((pair? ls) (or (= x (car ls))
147                        (dotted-member? x (cdr ls) =)))
148        (else (= x ls))))
149
150(define (dotted-map f lst)
151  (cond ((null? lst) '())
152        ((pair? lst) (cons (f (car lst))
153                           (dotted-map f (cdr lst))))
154        (else (f lst))))
155
156(define (dotted-for-each f lst)
157  (cond ((null? lst) '())
158        ((pair? lst) (begin (f (car lst))
159                            (dotted-for-each f (cdr lst))))
160        (else (f lst))))
161
162(define (kffd:every? p? ls)
163  (cond ((null? ls) #t)
164        ((pair? ls) (and (p? (car ls))
165                         (kffd:every? p? (cdr ls))))
166        (else #f)))
167
168(define (alist-ref key alist)
169  (cond ((assq key alist) => cdr)
170        (else #f)))
171
172(define (alist-delete key alist)             
173  (cond ((null? alist) 
174         '())
175        ((eq? (caar alist) key) 
176         (alist-delete key (cdr alist)))
177        (else
178         (cons (car alist)
179               (alist-delete key (cdr alist))))))
180
181(define (alist-delete-first key alist)             
182  (cond ((null? alist) 
183         '())
184        ((eq? (caar alist) key)
185         (cdr alist))
186        (else
187         (cons (car alist)
188               (alist-delete-first key (cdr alist))))))
189
190(define (alist-remove-duplicates alist)
191  (define (rem alist already)
192    (cond ((null? alist)               '())
193          ((memq (caar alist) already) (rem (cdr alist) already))
194          (else                        (cons (car alist)
195                                             (rem (cdr alist)
196                                                  (cons (caar alist)
197                                                        already))))))
198  (rem alist '()))
199
200
201;;;==========================================================================
202;;;
203;;; Infrastructure for hygiene:
204;;;
205;;;==========================================================================
206
207;; The current phase in the syntactic tower.
208
209(define kffd:*phase* (make-parameter 0))
210
211;; Creates a substitution context, in which bound-identifier=?
212;; identifiers share a location, so that substitutions can be done by an
213;; imperative update of an identifier (see bind! below) and we do not have
214;; to do any additional work to propagate substitution environments to leaves.
215;; The resulting hygiene algorithm is eager, has linear complexity, and is
216;; very fast.
217
218;; Initial-phase is the syntactic phase in force when the originating
219;; syntax or quasisyntax expression was expanded.
220
221(define (make-renaming-procedure initial-phase
222                                 colour
223                                 initial-environment
224                                 capturing?) 
225 
226  (let ((phase-correction (- (kffd:*phase*) initial-phase))
227        (inserted '())
228        (environment initial-environment)
229        (environment-dirty? #f)) 
230   
231    ;; The optional initial tower of binding names will always be supplied
232    ;; (avoiding a search through the initial environment) except in
233    ;; the case of datum->syntax-object. 
234   
235    ;; A tower of bindings is an alist ((phase . binding-name) ...)
236    ;; where phase = non-negative-integer | all | free
237    ;;
238    ;; all  - a binding name valid for all phases.
239    ;; free - a binding name prefix that is to be qualified by the phase
240    ;;        to obtain the binding name for a given phase.
241    ;;        This mechanism keeps namespaces for different phases
242    ;;        separate.
243    ;;
244    ;; See binding-name below for lookup sequence.
245   
246    (define (rename symbolic-name . maybe-tower) 
247      (cond ((assq symbolic-name inserted) => cdr)
248            (else
249             (if (null? maybe-tower)
250                 (cond ((env-lookup symbolic-name initial-environment)   
251                        => (lambda (entry)
252                             (insert symbolic-name entry #f)))
253                       (else (insert symbolic-name 
254                                     (list (cons 'free
255                                                 (paint-name symbolic-name
256                                                             colour)))
257                                     #t)))
258                 (insert symbolic-name (car maybe-tower) #t)))))
259   
260    (define (insert symbolic-name tower dirty?)
261     
262      (define (current-phase) (- (kffd:*phase*) phase-correction)) 
263     
264      (define (binding-name)     
265        (cond ((assq (current-phase) tower) => cdr)
266              ((assq 'all            tower) => cdr)
267              (else
268               (phase-qualify (cdr (assq 'free tower))
269                              (current-phase)))))
270     
271      (define bind!                 
272        (if capturing? 
273            (lambda (binding-name . maybe-phase) (void))
274            (lambda (binding-name . maybe-phase)
275              (set! tower
276                    (alist-cons (if (null? maybe-phase)
277                                    (current-phase)
278                                    (car maybe-phase))
279                                binding-name 
280                                tower))
281              (mark-dirty!))))
282     
283      (define unbind!
284        (if capturing?
285            (lambda () (void))
286            (lambda ()
287              (set! tower
288                    (alist-delete-first (current-phase) tower))
289              (mark-dirty!))))
290     
291      ;; Generates a representation of the identifier that can be inserted
292      ;; in generated code. 
293     
294      (define (reflect-syntax) 
295        `(',colour ',symbolic-name ,(- (current-phase) 1) ',tower ',(close-environment)))
296     
297      (define (mark-dirty!)
298        (set! dirty? #t)
299        (set! environment-dirty? #t))
300     
301      (define (mark-clean!)
302        (set! dirty? #f))
303     
304      (define (maybe-reflect-tower)
305        (if dirty?
306            (begin
307              (mark-clean!)
308              tower)
309            #f))
310     
311      (let ((new (make-identifier symbolic-name
312                                  binding-name
313                                  colour
314                                  bind!
315                                  unbind!
316                                  rename
317                                  close-environment
318                                  current-phase
319                                  reflect-syntax
320                                  maybe-reflect-tower))) 
321        (set! inserted (alist-cons symbolic-name new inserted))
322        (if dirty? 
323            (set! environment-dirty? #t)) 
324        new))
325   
326    ;; Provides a persistent snapshot of the current bindings.
327    ;; Invoked when compiling |syntax| forms and when executing
328    ;; make-capturing-identifier.
329   
330    ;; To support separate compilation, environments are
331    ;; included in the expanded representation of a library.
332    ;; We are careful to only record differences in environments
333    ;; that the serialized representation will be small.
334   
335    (define (close-environment)   
336      (if environment-dirty?
337          (begin
338            (set! environment
339                  (reflect-environment
340                   (let loop ((inserted inserted))
341                     (if (null? inserted)
342                         environment
343                         (let ((maybe-tower (maybe-reflect-tower (cdar inserted))))
344                           (if maybe-tower
345                               (alist-cons (caar inserted)
346                                           maybe-tower 
347                                           (loop (cdr inserted)))
348                               (loop (cdr inserted))))))))
349            (set! environment-dirty? #f)))
350      environment)
351   
352    rename))
353
354;; Meta-renaming procedures are used to implement syntax and
355;; quasisyntax expressions, which should paint identifiers with
356;; a new colour without unifying previously different colours. 
357;; This is done by appending a new colour to an identifier's
358;; existing colour. 
359
360(define (kffd:make-meta-renaming-procedure)
361  (let ((fresh-colour (generate-colour))
362        (colours->renamers '()))
363    (lambda (colour symbolic-name initial-phase tower environment) 
364      (let ((rename
365             (cond ((assq colour colours->renamers) => cdr)
366                   (else
367                    (let ((rename (make-renaming-procedure
368                                   initial-phase
369                                   (append-colours fresh-colour colour)
370                                   environment
371                                   #f))) 
372                      (set! colours->renamers
373                            (alist-cons colour rename colours->renamers))   
374                      rename)))))
375        (rename symbolic-name tower))))) 
376
377;; Used below for writing primitive macros in explicit renaming style.
378
379(define (make-primitive-renaming-procedure)     
380  (let ((rename
381         (make-renaming-procedure 0 no-colour (make-empty-env) #f)))
382    (lambda (symbolic-name)
383      (rename symbolic-name
384              (list (cons 'all symbolic-name)))))) 
385
386
387;;;=========================================================================
388;;;
389;;; The identifier type:
390;;;
391;;;=========================================================================
392
393
394(define-record identifier
395  symbolic-name
396  binding-name
397  colour
398  bind!
399  unbind!
400  renamer
401  close-environment 
402  current-phase
403  reflect-syntax 
404  maybe-reflect-tower)
405
406(define-record-printer (identifier id port)
407  (fprintf port "#<identifier ~a>" (identifier-symbolic-name id)) )
408
409(define (symbolic-name       id)                            (identifier-symbolic-name id))
410(define (binding-name        id)                            ((identifier-binding-name id)))
411(define (colour              id)                            (identifier-colour id))
412(define (bind!               id binding-name . maybe-phase) (apply (identifier-bind! id) binding-name maybe-phase))
413(define (unbind!             id)                            ((identifier-unbind! id)))
414(define (renamer             id)                            (identifier-renamer id))
415(define (close-environment   id)                            ((identifier-close-environment id))) 
416(define (current-phase       id)                            ((identifier-current-phase id)))
417(define (reflect-syntax      id)                            ((identifier-reflect-syntax id))) 
418(define (maybe-reflect-tower id)                            ((identifier-maybe-reflect-tower id)))
419
420;; Lexical bindings:
421
422(define (bind-lexical! id)
423  (bind! id (generate-id (string-append "@" (sym->str (symbolic-name id))))))
424
425(define (lexically-bound? id)
426  (char=? #\@ (string-ref (sym->str (binding-name id)) 0)))
427
428;; Toplevel binding forms use as binding name the name
429;; painted with the colour.  Since colours of macro-generated
430;; substitution contexts are secret, this causes binding names in
431;; macro-generated defines and define-syntaxes to be secret and
432;; protects imported library locations (including primitives) from
433;; being inadvertently rebound (although they can still be set!). 
434
435(define (bind-toplevel! id)
436  (bind! id 
437         (phase-qualify (paint-name (symbolic-name id) (colour id))
438                        (current-phase id))))                                 
439
440;; Imported bindings:
441
442(define (kffd:import! symbolic-name imported-name context-id . maybe-phase) 
443  (let ((local-id ((renamer context-id) symbolic-name)))
444    (apply bind! local-id imported-name maybe-phase))) 
445
446
447;;;=====================================================================
448;;;
449;;; Comparing identifiers:
450;;;
451;;;=====================================================================
452
453(define (bound-identifier=? x y)             
454  (and (identifier? x)
455       (eq? x y)))
456
457(define (free-identifier=? x y)                           
458  (and (identifier? x)
459       (identifier? y)
460       (eq? (binding-name x)
461            (binding-name y))))
462
463;; This should be used to compare literals independently of library.
464
465(define (literal-identifier=? x y)
466  (and (identifier? x)
467       (identifier? y)
468       (or (eq? (binding-name x)
469                (binding-name y))                             
470           (and (not (lexically-bound? x))
471                (not (lexically-bound? y))
472                (eq? (symbolic-name x)
473                     (symbolic-name y))))))
474
475;; For internal use.  Equivalent to 
476;; (free-identifier=? x (syntax symbol))
477
478(define (free=? x symbol)           
479  (and (identifier? x)
480       (eq? (binding-name x) symbol))) 
481
482;; For internal use.  Equivalent to   
483;; (literal-identifier=? x (syntax symbol))
484
485(define (literal=? x symbol)           
486  (and (identifier? x)
487       (or (eq? (binding-name x) symbol)
488           (and (not (lexically-bound? x))
489                (eq? (symbolic-name x) symbol)))))
490
491
492;;;=====================================================================
493;;;
494;;; Intentional capture:
495;;;
496;;;=====================================================================
497
498(define (datum->syntax-object tid datum) 
499  (if (identifier? tid)
500      (datum->syntax (renamer tid) datum)
501      (syntax-error "Datum->syntax-object: First argument must be identifier:" tid)))
502
503(define (datum->syntax rename datum)
504  (sexp-map (lambda (leaf)
505              (cond ((const? leaf)  leaf)
506                    ((symbol? leaf) (rename leaf))
507                    (else
508                     (syntax-error "Datum->syntax-object: Invalid datum:" leaf))))
509            datum))                   
510
511(define (syntax-object->datum stx)
512  (sexp-map (lambda (leaf)
513              (cond ((const? leaf)      leaf)
514                    ((identifier? leaf) (symbolic-name leaf))
515                    (else
516                     (syntax-error "Syntax-object->datum: Invalid syntax object:" leaf))))
517            stx))
518
519;; A fluid identifier in a binding form will capture
520;; unbound free-identifier=? identifiers in its scope.
521;; The idetifier tid provides the environment for
522;; determining the denotation of the identifier.
523
524(define (make-capturing-identifier tid symbolic-name)
525  (or (and (identifier? tid)
526           (symbol? symbolic-name))
527      (syntax-error "Make-fluid-identifier :: identifier symbol -> identifier"
528                    tid symbolic-name))
529  (let ((rename (make-renaming-procedure 
530                 (current-phase tid)
531                 (colour tid)
532                 (close-environment tid)
533                 #t)))
534    (rename symbolic-name)))
535
536
537;;;=======================================================================
538;;;
539;;; Environments:
540;;;
541;;;=======================================================================
542
543;; Table of reflected environments:
544
545(define kffd:*environments* (make-parameter '()))
546
547;; An environment is either a reflected environment (symbol)
548;; or an association possibly improper list whose tail may be a reflected   
549;; environment.
550
551(define (env-lookup key env)
552  (cond ((null? env) #f)
553        ((pair? env) (if (eq? key (caar env))
554                         (cdar env)
555                         (env-lookup key (cdr env))))
556        (else (env-lookup key 
557                          (reify-environment env)))))
558
559;; Returns a single-symbol representation of an environment
560;; that can be included in object code.
561
562(define (reflect-environment env) 
563  (let ((key (generate-id "env")))
564    (kffd:*environments* (alist-cons key
565                                     (cons (kffd:*current-library-name*) env)
566                                     (kffd:*environments*)))
567    key))
568
569;; The inverse of the above.
570
571(define (reify-environment reflected-env)
572  (cdr (alist-ref reflected-env (kffd:*environments*))))
573
574
575;;;=======================================================================
576;;;
577;;; Colours:
578;;;
579;;;=======================================================================
580
581;; To support separate compilation, generated colours should be
582;; globally unique.
583
584(define (generate-colour)
585  (generate-id "#"))
586
587(define no-colour            (str->sym ""))
588(define source-colour        (str->sym "#top"))
589(define (library-colour name) (generate-id (string-append "#" (sym->str name))))
590
591;; Appending colours c1 and c2 must give a colour disjoint from
592;; the range of generate-colour unless either is no-colour. 
593
594(define (append-colours c1 c2)
595  (str->sym 
596   (string-append (sym->str c1) 
597                  (sym->str c2))))
598
599;; Generates the painted names used for free toplevel or
600;; library identifiers, or secret names in generated defines.
601;; Painted names should be disjoint from all source symbols
602;; and all previous and future generate-ids. 
603
604(define (paint-name symbolic-name colour)   
605  (str->sym                             
606   (string-append (sym->str symbolic-name)
607                  (sym->str colour)))) 
608
609;; Further qualifies a name by a syntactic phase.
610
611(define (phase-qualify name phase)
612  (str->sym 
613   (string-append (sym->str name)
614                  (if (= phase 0) 
615                      "" 
616                      (string-append "'"                             
617                                     (number->string phase))))))
618
619
620;;;=========================================================================
621;;;
622;;; Expander dispatch:
623;;;
624;;;=========================================================================
625
626;; Debugging information displayed by syntax-error.
627
628(define *backtrace* (make-parameter '())) 
629
630;; Transformers are user-defined macros.
631;; Expanders are system macros that fully expand
632;; their arguments to core Scheme.
633
634(define (expand t)
635  (parameterize ((*backtrace* (cons t (*backtrace*))))
636    (cond ((identifier? t)                 (binding-name t))       
637          ((syntax-use t (*transformers*)) => (lambda (transformer)
638                                                (expand (transformer t))))
639          ((syntax-use t expanders)        => (lambda (expander)
640                                                (expander t)))
641          ((list?  t)                      (map-in-order expand t))
642          ((const? t)                      t)
643          (else
644           (syntax-error "Expand: Invalid syntax object:" t)))))
645
646;; Used to determine internal defintions in lambda.
647
648(define (head-expand t)
649  (parameterize ((*backtrace* (cons t (*backtrace*))))
650    (cond
651     ((syntax-use t (*transformers*)) => (lambda (transformer)
652                                           (head-expand (transformer t))))
653     (else t))))
654
655(define (const? t)
656  (or (null?          t)
657      (boolean?       t)
658      (##sys#number?  t)
659      (string?        t)
660      ; (keyword?       t)  AvT - having this breaks things
661      (eof-object?    t)
662      (char?          t)))
663
664(define (syntax-use t table)           
665  (and (pair? t)                         
666       (identifier? (car t))
667       (alist-ref (binding-name (car t)) table)))
668
669(define expanders '())
670
671(define (install-expanders)
672  (set! expanders
673        `((lambda           . ,expand-lambda)
674          (syntax           . ,expand-syntax)
675          (quasisyntax      . ,expand-quasisyntax)
676          (quote            . ,syntax-object->datum)
677          (,'quasiquote     . ,expand-quasiquote)
678          (embedded-syntax  . ,expand-embedded-syntax)
679          (define           . ,expand-define)
680          (define-syntax    . ,expand-define-syntax)
681          (let-syntax       . ,expand-let-syntax)
682          (letrec-syntax    . ,expand-letrec-syntax) 
683          (begin-for-syntax . ,expand-begin-for-syntax)
684          (around-syntax    . ,expand-around-syntax)
685          (set-syntax!      . ,expand-set-syntax)
686          (library           . ,expand-library)
687          (export-0           . ,expand-export)
688          (import-0   . ,expand-import))))
689
690;; Global transformer table:
691;; This could benefit from being implemented
692;; as an O(1) data structure:
693
694(define *transformers* (make-parameter '()))
695
696(define (kffd:register-transformer name proc)
697  (*transformers* (alist-cons name proc (*transformers*))))
698
699
700;;;=========================================================================
701;;;
702;;; Syntax:
703;;;
704;;;=========================================================================
705
706(define (expand-syntax form)
707  (define (descend x)
708    (cond ((pair? x)       `(cons ,(descend (car x)) ,(descend (cdr x))))
709          ((vector? x)     `(list->vector ,(descend (vector->list x))))
710          ((identifier? x) `(,(kffd:*current-renamer*) ,@(reflect-syntax x))) 
711          ((const? x)      `(quote ,x))
712          (else
713           (syntax-error "Syntax: Invalid element in syntax object:" form))))
714  (nest-in-fresh-scope 
715   (lambda () (descend (cadr form)))))
716
717
718(define kffd:*current-renamer* (make-parameter 'no-root-renamer)) 
719(define *in-syntax*       (make-parameter #f))
720
721(define (nest-in-fresh-scope thunk)
722  (if (*in-syntax*)
723      (thunk)
724      (parameterize ((kffd:*current-renamer* (generate-id "rename"))
725                     (*in-syntax* #t) )
726        `(let ((,(kffd:*current-renamer*) (kffd:make-meta-renaming-procedure)))
727           ,(thunk)))))
728
729
730;;;=========================================================================
731;;;
732;;; Quasisyntax and quasiquote:
733;;;
734;;;=========================================================================
735
736
737(define (quasi x quasi-tag id-quoter) 
738 
739  (define (qq-expand x level)
740   
741    (cond
742      ((tag-backquote? x)                `(list ,(id-quoter (car x))
743                                                ,(qq-expand (cadr x) (+ level 1))))
744      ((and (= level 0)
745            (tag-comma? x)
746            (pair? (cdr x)) 
747            (null? (cddr x)))            (expand (cadr x)))           
748      ((and (= level 0)
749            (pair? x)
750            (tag-comma? (car x)))        `(append (list . ,(map expand (cdar x)))
751                                                  ,(qq-expand (cdr x) 0)))
752      ((and (= level 0)
753            (pair? x)
754            (tag-comma-atsign? (car x))) `(append (append . ,(map expand (cdar x)))
755                                                  ,(qq-expand (cdr x) 0)))
756      ((and (> level 0)
757            (or (tag-comma? x)
758                (tag-comma-atsign? x)))  `(cons ,(id-quoter (car x))
759                                                ,(qq-expand (cdr x) (- level 1))))
760      ((pair? x)                         `(cons ,(qq-expand (car x) level)
761                                                ,(qq-expand (cdr x) level)))
762      ((null? x)                         `(quote ()))
763      ((identifier? x)                   (id-quoter x))
764      ((vector? x)                       `(list->vector
765                                           ,(qq-expand (vector->list x) level)))
766      (else                              (expand x))))
767 
768  (define (tag-comma? x)        (and (pair? x) 
769                                     (literal=? (car x) `unquote)))
770  (define (tag-comma-atsign? x) (and (pair? x)
771                                     (literal=? (car x) `unquote-splicing)))
772  (define (tag-backquote? x)    (and (pair? x)
773                                     (pair? (cdr x))
774                                     (null? (cddr x))
775                                     (literal=? (car x) quasi-tag)))
776 
777  (qq-expand x 0))
778
779
780(define (expand-quasisyntax form)
781  (or (and (pair? (cdr form))
782           (null? (cddr form))) 
783      (syntax-error "Quasisyntax:  Should have one argument"))
784  (nest-in-fresh-scope
785   (lambda () 
786     (quasi (cadr form)
787            'quasisyntax
788            (lambda (id) (expand-syntax `(dummy ,id)))))))
789
790
791(define (expand-quasiquote form)
792  (or (and (pair? (cdr form))
793           (null? (cddr form))) 
794      (syntax-error "Quasiquote:  Should have one argument"))
795  (quasi (cadr form)
796         'quasiquote
797         (lambda (id) `(quote ,(syntax-object->datum id)))))
798
799
800;;;=========================================================================
801;;;
802;;; Embedded-syntax:
803;;;
804;;;=========================================================================
805
806;; Embedded-syntax just stores its argument for later access.
807;; The embedded-syntax environment is not preserved across
808;; compilation boundaries.
809
810(define *embedded-syntaxes* (make-parameter '()))
811
812(define (expand-embedded-syntax form)
813  (or (and (pair? (cdr form))
814           (null? (cddr form))) 
815      (syntax-error "Embedded-syntax:  Should have one argument"))
816  (let ((key (generate-id)))
817    (*embedded-syntaxes* 
818     (alist-cons key
819                 (cadr form)
820                 (*embedded-syntaxes*)))
821    `(kffd:embedded-syntax-lookup ',key)))
822
823
824(define (kffd:embedded-syntax-lookup key)                     
825  (cond ((assq key (*embedded-syntaxes*)) => cdr)
826        (else
827         (syntax-error "Embedded-syntax:  Used across compilation boundary:"))))
828
829
830;;;=========================================================================
831;;;
832;;; Lambda:
833;;;
834;;;=========================================================================
835
836
837;; Here we expand internal definitions to internal definitions in
838;; the host Scheme, thus preserving the semantics of the latter. 
839;; We could just as easily have expanded to a letrec or letrec*.
840
841(define (expand-lambda exp)
842  (if (and (pair?    (cdr exp))
843           (formals? (cadr exp))
844           (list?    (cddr exp)))
845      (let ((formals (cadr exp))
846            (body    (cddr exp)))
847        (dotted-for-each bind-lexical! formals)
848        (scan-body body
849                   (lambda (definitions exp exps)
850                     (let ((result
851                            `(lambda ,(dotted-map binding-name formals)
852                               ,@(map (lambda (def)
853                                        `(define ,(binding-name (cadr def))
854                                           ,(expand (caddr def))))
855                                      definitions)
856                               ,exp
857                               ,@(map expand exps))))
858                       (for-each unbind! (map cadr definitions)) 
859                       (dotted-for-each unbind! formals)
860                       result))))
861      (syntax-error "Invalid lambda syntax:" exp)))
862
863;; Here we expand the first expression atomically in case expansion
864;; relies on side effects.  This is important in a procedural macro
865;; system.  So that the first expression will be expanded correctly,
866;; definition-bound identifiers are bound as soon as they are
867;; encountered. 
868
869(define (scan-body forms k)
870  (let loop ((forms forms)
871             (defs  '()))
872    (if (null? forms)
873        (syntax-error "Lambda: Empty body.")
874        (let ((form  (head-expand (car forms)))
875              (forms (cdr forms)))
876          (cond ((define? form)                           
877                 (let ((def (normalize-definition form #f)))
878                   (bind-lexical! (cadr def)) 
879                   (loop forms
880                         (cons def defs))))
881                ((begin? form)
882                 (loop (append (cdr form) forms)
883                       defs))
884                (else
885                 (k (reverse defs) 
886                    (expand form) 
887                    forms)))))))   
888
889(define (make-operator-predicate name)
890  (lambda (t)
891    (and (pair? t)
892         (free=? (car t) name))))
893
894(define define? (make-operator-predicate 'define))
895(define begin?  (make-operator-predicate 'begin))
896
897(define (formals? s)
898  (or (null? s)
899      (identifier? s)
900      (and (pair? s)
901           (identifier? (car s))
902           (formals? (cdr s))
903           (not (dotted-member? (car s)             
904                                (cdr s)
905                                bound-identifier=?)))))
906
907
908;;;=========================================================================
909;;;
910;;; Define, define-syntax! and set-syntax!
911;;;
912;;;=========================================================================
913
914
915(define (normalize-definition t syntax-definition?)
916  (cond ((pair? (cdr t))
917         (let ((_    (car t))
918               (head (cadr t))
919               (body (cddr t)))
920           (cond ((and (identifier? head)
921                       (pair? body)
922                       (null? (cdr body)))
923                  `(,_ ,head . ,body))
924                 ((and (identifier? head) 
925                       (not syntax-definition?) 
926                       (null? body))
927                  `(,_ ,head (,((make-primitive-renaming-procedure) '##sys#void))))
928                 ((and (pair? head)
929                       (identifier? (car head))
930                       (formals? (cdr head)))
931                  (let ((r (make-primitive-renaming-procedure)))
932                    (if syntax-definition?
933                        `(,_ ,(car head)
934                           ,(let ((transformer (r (symbolic-name (car head)))))
935                              `((,(r 'lambda) (,transformer)
936                                  (,(r 'lambda) (,(r 'form))
937                                    (,(r 'apply) ,transformer ,(r 'form))))
938                                (,(r 'lambda) (,(r 'dummy) . ,(cdr head)) . ,body))))
939                        `(,_ ,(car head)
940                           (,(r 'lambda) ,(cdr head) . ,body)))))
941                 ((and (pair? head) 
942                       (not syntax-definition?))
943                  (let-values (((name exp) (expand-curried-define t head body)))
944                    `(,_ ,name ,exp)))
945                 (else (syntax-error "Syntax error in definition:" t)))))
946        (else (syntax-error "Syntax error in definition:" t))))
947
948(define (expand-curried-define t head body)
949  (let* ((name #f)
950         (r (make-primitive-renaming-procedure)))
951    (define (loop head body)
952      (cond ((and (identifier? (car head))
953                  (formals? (cdr head)))
954             (set! name (car head))
955             `(,(r 'lambda) ,(cdr head) ,@body) )
956            ((and (pair? head)
957                  (formals? (cdr head)))
958             (loop (car head) `((,(r 'lambda) ,(cdr head) ,@body))))
959            (else (syntax-error "Invalid curried definition" t))))
960    (let ((exp (loop head body)))
961      (values name exp))))
962
963
964
965;; A macro expands to an instance of for-syntax, which
966;; is a no-op at toplevel but will be further processed
967;; when inside a library.
968
969(define (expand-define-syntax t)
970  (let ((t (normalize-definition t #t)))
971    (bind-toplevel! (cadr t))
972    (let ((expanded
973           `(kffd:register-transformer ',(binding-name (cadr t))
974                                       ,(parameterize ((kffd:*phase* (+ (kffd:*phase*) 1)))
975                                          (expand (caddr t))))))
976      (kffd:eval expanded) 
977      `(kffd:for-syntax (quote ,expanded)))))       
978
979(define (expand-define t)
980  (let ((t (normalize-definition t #f)))
981    (bind-toplevel! (cadr t))
982    (*transformers* (alist-delete (binding-name (cadr t))
983                                  (*transformers*)))     
984    `(define ,(binding-name (cadr t))
985       ,(expand (caddr t)))))
986
987(define (expand-set-syntax t)
988  (or (and (list? t)
989           (= (length t) 3)
990           (identifier? (cadr t)))
991      (syntax-error))
992  (let ((expanded
993         `(kffd:set-syntax! ',(binding-name (cadr t))
994                            ,(parameterize ((kffd:*phase* (+ (kffd:*phase*) 1)))
995                               (expand (caddr t))))))
996    (kffd:eval expanded)
997    `(kffd:for-syntax (quote ,expanded))))               
998
999(define (kffd:set-syntax! binding-name transformer)           
1000  (cond ((assq binding-name (*transformers*))
1001         => (lambda (entry) 
1002              (set-cdr! entry transformer)))
1003        (else
1004         (error "Set-syntax! Unbound variable:" binding-name))))
1005
1006
1007;;;=========================================================================
1008;;;
1009;;; Let[rec]-syntax:
1010;;;
1011;;;=========================================================================
1012
1013(define (expand-let-syntax t)       
1014  (kffd:scan-let t
1015                 (lambda (formals exps body)
1016                   (or (formals? formals)
1017                       (syntax-error "Invalid formals:" formals))
1018                   (let ((transformers 
1019                          (parameterize ((*in-syntax* #f  )
1020                                         (kffd:*phase* (+ (kffd:*phase*) 1)) )
1021                            (map (lambda (exp) 
1022                                   (kffd:eval (expand exp)))
1023                                 exps))))
1024                     (for-each bind-lexical! formals)
1025                     (emit-lexical-syntax formals transformers body)))))
1026
1027(define (expand-letrec-syntax t)
1028  (kffd:scan-let t
1029                 (lambda (formals exps body)
1030                   (or (formals? formals)
1031                       (syntax-error "Invalid formals:" formals))
1032                   (for-each bind-lexical! formals)
1033                   (let ((transformers 
1034                          (parameterize ((*in-syntax* #f)
1035                                         (kffd:*phase* (+ (kffd:*phase*) 1)))
1036                            (map (lambda (exp) 
1037                                   (kffd:eval (expand exp)))
1038                                 exps))))
1039                     (emit-lexical-syntax formals transformers body)))))
1040
1041
1042;; Let[rec]-syntax is implemented as a splicing form, wrapping its
1043;; body in an implicit begin instead of let as in R5RS.
1044;; This is a more useful semantics, allowing the body to expand
1045;; into topphase definitions, and the R5RS semantics can be
1046;; obtained by explicitly writing the let. 
1047
1048(define (emit-lexical-syntax formals transformers body)
1049  (parameterize ((*transformers*
1050                  (append (map (lambda (formal transformer)
1051                                 (cons (binding-name formal)
1052                                       transformer))
1053                               formals
1054                               transformers)
1055                          (*transformers*))))
1056    (let ((result (map-in-order expand body)))     
1057      (for-each unbind! formals)
1058      `(begin ,@result))))
1059
1060(define (kffd:scan-let t k)               
1061  (or (and (pair? (cdr t))
1062           (list? (cadr t))
1063           (list? (cddr t))
1064           (kffd:every? (lambda (binding)
1065                          (and (pair? binding)
1066                               (identifier? (car binding))
1067                               (pair? (cdr binding))
1068                               (null? (cddr binding))))
1069                        (cadr t)))
1070      (syntax-error))
1071  (let ((formals (map car (cadr t)))
1072        (exps    (map cadr (cadr t)))
1073        (body    (cddr t)))
1074    (k formals
1075       exps
1076       body)))
1077
1078
1079;;;===========================================================================
1080;;;
1081;;; Begin-for-syntax:
1082;;;
1083;;;===========================================================================
1084
1085;; Expands enclosed code at phase + 1 and evaluate at expansion time.
1086;; The expanded code cannot be discarded - it needs to be included in
1087;; the proper way in the library so that libraries will compose correctly.
1088;; We therefore quote it and wrap it in for-syntax, which is a no-op
1089;; when evaluated at toplevel, but will be further processed when
1090;; included in a library.
1091
1092(define (expand-begin-for-syntax t)
1093  (or (list? (cdr t))
1094      (syntax-error))
1095  (parameterize ((kffd:*phase* (+ (kffd:*phase*) 1)))
1096    (let ((result
1097           (map-in-order expand (cdr t))))
1098      (kffd:eval `(begin ,@result))
1099      `(begin ,@(map (lambda (form) 
1100                       `(kffd:for-syntax (quote ,form)))                             
1101                     result)))))
1102
1103(define (kffd:for-syntax . exps) (void))
1104
1105
1106;;;===========================================================================
1107;;;
1108;;; Syntactic-wind:
1109;;;
1110;;;===========================================================================
1111
1112;; Allows code to be executed before and after expanding an expression.
1113
1114(define (expand-around-syntax t)
1115  (or (and (list? t)
1116           (= (length t) 4))
1117      (syntax-error))
1118  (parameterize ((kffd:*phase* (+ (kffd:*phase*) 1)))
1119    (kffd:eval (expand (cadr t))))
1120  (let ((result (expand (caddr t))))
1121    (parameterize ((kffd:*phase* (+ (kffd:*phase*) 1)))
1122      (kffd:eval (expand (cadddr t)))
1123      result)))
1124
1125
1126;;;============================================================================
1127;;;
1128;;; Libraries:
1129;;;
1130;;;============================================================================
1131
1132
1133(define (kffd:make-library name exports)
1134  (list name exports))
1135
1136(define library-name    car)
1137(define library-exports cadr)
1138
1139
1140(define kffd:*loaded-libraries* (make-parameter '()))
1141
1142;; mode = visited | invoked
1143
1144(define (kffd:load-library mode library action-thunk)
1145  (let ((name (string->symbol (library-name library))))
1146    (if (not (lookup-library name mode (kffd:*phase*)))
1147        (begin
1148          (kffd:*loaded-libraries* (alist-cons (list name mode (kffd:*phase*))
1149                                               library
1150                                               (kffd:*loaded-libraries*)))
1151          (action-thunk)
1152          (void)))))
1153
1154(define (lookup-library name mode phase)
1155  #+debug (pp `(LOOKUP: ,name))
1156  (cond ((assoc (list name mode phase) (kffd:*loaded-libraries*)) => cdr)
1157        (else #f)))
1158
1159(define kffd:*current-library-name* (make-parameter ""))
1160
1161(define (mangle-top str)
1162  (str->sym (string-append "library#" (if (symbol? str) (sym->str str) str))))
1163
1164(define-constant builtin-libraries
1165  '(("chicken://ffi" . chicken-ffi-library-unit)
1166    ("chicken://macros" . chicken-macros-library-unit)
1167    ("chicken://extras" . extras-library-unit)
1168    ("chicken://posix" . posix-library-unit)
1169    ("chicken://lolevel" . lolevel-library-unit)
1170    ("chicken://regex" . regex-library-unit)
1171    ("chicken://utils" . utils-library-unit)
1172    ("scheme://srfi-1" . srfi-1-library-unit)
1173    ("scheme://srfi-4" . srfi-4-library-unit)
1174    ("scheme://srfi-13" . srfi-13-library-unit)
1175    ("scheme://srfi-14" . srfi-14-library-unit)
1176    ("scheme://srfi-18" . srfi-18-library-unit) ) )
1177
1178(define-constant libraries-wrapper "chicken-libraries")
1179
1180(define (kffd:ensure-library name)
1181  (define (fetch top)
1182    (let ((lib (string-append
1183                (repository-path)
1184                (string ##sys#pathname-directory-separator) 
1185                libraries-wrapper
1186                ##sys#load-dynamic-extension) ) )
1187      (##sys#load-library top lib)))
1188  (let ((topname (mangle-top name)))
1189    (unless (##sys#symbol-has-toplevel-binding? topname)
1190      (cond ((assoc name builtin-libraries) => (lambda (x) (fetch (cdr x))))
1191            (else
1192             (require 
1193              (string->symbol
1194               (let ((len (string-length name)))
1195                 (let loop ((i 0))
1196                   (cond ((fx>= i len) name)
1197                         ((and (char=? #\: (string-ref name i))
1198                               (fx< (fx+ i 2) len)
1199                               (char=? #\/ (string-ref name (fx+ i 1)))
1200                               (char=? #\/ (string-ref name (fx+ i 2))) )
1201                          (string-append (substring name 0 i) "-" (substring name (fx+ i 3))) )
1202                         (else (loop (fx+ i 1))) ) ) ) ) ) ) )
1203      (unless (##sys#symbol-has-toplevel-binding? topname)
1204        (##sys#error 'import "can not find library" name) ) ) ) )
1205
1206(define (expand-library exp)
1207 
1208  (or (string=? (kffd:*current-library-name*) "")
1209      (syntax-error "Nested libraries are not allowed:" exp))
1210 
1211  (or (and (list?       exp)
1212           (>= (length exp) 3)
1213           (string? (cadr exp))
1214           (string? (caddr exp)) )
1215      (syntax-error "Invalid library syntax:" exp))
1216 
1217  ;; Since imported libraries may be mutated during expansion
1218  ;; that follows, we make sure that we continue with a clean
1219  ;; slate afterwards.  This causes all libraries imported after
1220  ;; expanding this library to be re-instantiated. 
1221 
1222  (kffd:*loaded-libraries* '())
1223 
1224  ;; To ensure repeatability and consistency with incremental compilation,
1225  ;; libraries are expanded in a fresh environment.
1226 
1227  (parameterize ((kffd:*current-library-name*         (cadr exp))
1228                 (*transformers*                     (*transformers*))
1229                 (kffd:*environments*                '())
1230                 (*embedded-syntaxes*                '())
1231                 (kffd:*loaded-libraries* '()) )
1232    (define primitive-rename (make-primitive-renaming-procedure))
1233    (let* ((name     (cadr exp))
1234           (language (caddr exp))
1235                       
1236           ;; Paint the entire body with a new colour in a
1237           ;; clean Scheme environment, achieving a private
1238           ;; namespace.
1239                       
1240           (rename   (make-renaming-procedure
1241                      0
1242                      (library-colour (str->sym name)) 
1243                      (make-empty-env)
1244                      #f))
1245           (initial  (expand-import `(,(primitive-rename 'import) 
1246                                      ,(rename 'import)  ; import context
1247                                      ,language
1248                                      ,(primitive-rename 'identity) 
1249                                      ,(primitive-rename 'all))))
1250           (body     (datum->syntax rename (syntax-object->datum (cdr exp))))
1251           (exps     (cdr body)) 
1252           (expanded (cons initial (flatten-for-syntax (flatten-begins (map-in-order expand exps)))))
1253           (exports  (extract-exports expanded))
1254           (requirements (extract-requirements expanded))
1255           (defines  (extract-defines (append expanded
1256                                              (extract-for-syntax expanded)))) 
1257           (code
1258            (let ((mode (generate-id "mode")))
1259              `(begin ,@(map (lambda (def)
1260                               `(define ,(cadr def) (##sys#void)))
1261                             defines)   
1262                      (define ,(mangle-top name)
1263                        (lambda (,mode)
1264                          (case ,mode
1265                            ((unbind)
1266                             (##sys#void) ;; prevents possibly empty clause
1267                             ,@(map (lambda (def)
1268                                      `(set! ,(cadr def) (##sys#void)))
1269                                    defines))
1270                            (else
1271                             (kffd:load-library 
1272                              ,mode 
1273                              (kffd:make-library 
1274                               ',name   
1275                               ',(map (lambda (name-export)
1276                                        (cons (symbolic-name 
1277                                               (car name-export))
1278                                              (binding-name 
1279                                               (cadr name-export))))
1280                                      exports))
1281                              ;; action-thunk
1282                              (lambda ()
1283                                ,@requirements
1284                                (case ,mode
1285                                  ((visited)
1286                                   (kffd:*environments* 
1287                                    (append (kffd:uncompress-envs 
1288                                             (quote ,(compress-envs
1289                                                      (kffd:*environments*))))
1290                                            (kffd:*environments*)))
1291                                   ,@(defines->sets 
1292                                       (extract-for-syntax expanded)))   
1293                                  ((invoked)
1294                                   (void) ;; prevents possibly empty clause
1295                                   ,@(defines->sets
1296                                       (delete-for-syntax
1297                                        (delete-exports expanded)))))))))))))))
1298                   
1299      ;; Unbind imported libraries:
1300                   
1301      (for-each (lambda (library-entry)
1302                  (kffd:eval `(,(mangle-top (caar library-entry)) 'unbind)))
1303                (kffd:*loaded-libraries*))                     
1304                   
1305      (kffd:eval code)                                       
1306      code)))
1307
1308(define (extract-requirements forms)
1309  (let loop ((forms forms))
1310    (cond ((null? forms) '())
1311          ((and (pair? (car forms)) (eq? 'kffd:ensure-library (caar forms)))
1312           (cons (car forms) (loop (cdr forms))) )
1313          (else (loop (cdr forms))))))
1314
1315(define (flatten-begins forms)
1316  (let loop ((result '())
1317             (forms forms)) 
1318    (if (null? forms)
1319        (reverse result)
1320        (let ((form  (car forms))
1321              (forms (cdr forms)))
1322          (if (call? form 'begin)
1323              (loop result
1324                    (append (cdr form) forms))
1325              (loop (cons form result) 
1326                    forms))))))
1327
1328(define (call? form name)
1329  (and (pair? form)
1330       (eq? (car form) name)))
1331
1332;; Each for-syntax has a single argument.
1333;; Flattens (for-syntax '(begin e ...))  -> (for-syntax 'e) ...
1334;;          (for-syntax '(for-syntax e)) -> (for-syntax 'e)
1335;; and recurses.
1336
1337(define (flatten-for-syntax forms) 
1338  (apply append 
1339         (map (lambda (form)
1340                (if (call? form 'kffd:for-syntax)
1341                    (let ((embedded (cadadr form)))
1342                      (cond
1343                        ((call? embedded 'kffd:for-syntax) (flatten-for-syntax (list embedded)))
1344                        ((call? embedded 'begin)           (flatten-for-syntax (map (lambda (form) 
1345                                                                                      `(kffd:for-syntax ',form))
1346                                                                                    (cdr embedded))))
1347                        (else (list form))))
1348                    (list form)))
1349              forms)))
1350
1351;; Extract expressions e occurring in forms (for-syntax 'e)
1352
1353(define (extract-for-syntax forms)                     
1354  (map cadadr
1355       (filter (lambda (form) 
1356                 (call? form 'kffd:for-syntax))
1357               forms)))
1358
1359(define (delete-for-syntax forms)               
1360  (filter (lambda (form) 
1361            (not (call? form 'kffd:for-syntax)))
1362          forms))
1363
1364(define (extract-exports forms)
1365  (apply append
1366         (map cdr
1367              (filter (lambda (form)
1368                        (call? form 'export-0))
1369                      forms))))
1370
1371(define (delete-exports forms)               
1372  (filter (lambda (form) 
1373            (not (call? form 'export-0)))
1374          forms))
1375                                               
1376
1377(define (extract-defines forms)
1378  (filter (lambda (form)
1379            (call? form 'define))
1380          forms))
1381
1382(define (defines->sets forms)
1383  (map (lambda (form)
1384         (if (call? form 'define)
1385             `(set! ,(cadr form) ,(caddr form)) 
1386             form))
1387       forms))
1388
1389
1390;; Internal export:
1391;; Preserve identifiers in (cdr t), since they
1392;; may still be (impperatively) bound upon further
1393;; processing of library form.
1394
1395(define (expand-export t)
1396  `(export-0 ,@(cdr t)))
1397
1398;; Semantics:
1399;;
1400;; To invoke a library at phase N:
1401;;
1402;;    * Invoke at phase N any library that is imported by this library
1403;;      for run time, and that is not yet invoked at phase N.
1404;;    * Evaluate all variable definitions and top-level expressions within
1405;;      the library. (Macro definitions are not evaluated.)
1406;;
1407;; To visit a library at phase N:
1408;;
1409;;    * For each k >= 1, invoke at phase N+k any library that is imported
1410;;      by this library for .... (phase k), and that is not yet invoked at
1411;;      phase N+k.
1412;;    * For each k >= 0, visit at phase N+k any library that is imported by
1413;;      this library for .... (phase k), and that is not yet visited at phase
1414;;      N+k.
1415;;    * Evaluate all syntax definitions within the library.
1416;;      (Top-level expressions are not evaluated, and the right-hand sides
1417;;      of variable definitions are not evaluated.)
1418
1419(define (expand-import t)
1420  (let* ((template  (cadr t))
1421         (libname (caddr t))
1422         (name      (str->sym libname))
1423         (sname (mangle-top name))
1424         (renamer   (parameterize ((kffd:*phase* (+ (kffd:*phase*) 1)))
1425                      (kffd:eval (expand (cadddr t)))))
1426         (maybe-all (syntax-object->datum (cddddr t))))
1427
1428    ;; For each k >= 0, visit at phase (*phase*) = N + k any library imported
1429    ;; by this library at phase k, and that is not yet visited at phase
1430    ;; N+k.
1431
1432    ;; Import expressions for .... (phase k) have already been translated by
1433    ;; wrapping them in nested begin-for-syntax commands.  When expanded, these
1434    ;; will cause the global (*phase*) parameter to have been incremented to
1435    ;; N + k.
1436
1437    (kffd:ensure-library libname)
1438    (kffd:eval `(,sname 'visited))
1439
1440    ;; This is a little hack for making the "language"
1441    ;; available in all phases.
1442   
1443    (and (pair? maybe-all)
1444         (eq? (car maybe-all) 'all)
1445         (kffd:eval `(,sname 'invoked)))
1446   
1447    ;; Library has just been visited, so it is in the registry.
1448   
1449    (let* ((exports (library-exports (lookup-library name 'visited (kffd:*phase*)))))
1450     
1451      (for-each (lambda (export)
1452                  (let ((import-name (renamer (car export))))
1453                    (if import-name
1454                        (apply kffd:import! import-name (cdr export) template maybe-all))))
1455                exports)
1456      `(begin
1457         (kffd:ensure-library ,libname)
1458         (kffd:for-syntax (quote (,sname 'visited)))
1459         (,sname 'invoked)))))
1460
1461
1462;;;===========================================================================
1463;;;
1464;;; Compression stub:
1465;;;
1466;;;===========================================================================
1467
1468;; Because close-environment is careful to keep sharing and
1469;; not record duplicate information, not much is needed here.
1470;; We need do nothing more than filter out the environments
1471;; needed for the current library, discarding those that may have
1472;; been accumulated when importing other libraries.
1473
1474(define (kffd:uncompress-envs compressed) compressed)
1475
1476(define (compress-envs envs)
1477  (alist-remove-duplicates (filter-current-library envs)))
1478
1479(define (filter-current-library envs)
1480  (filter (lambda (env) 
1481            (string=? (cadr env) (kffd:*current-library-name*)))
1482          envs))
1483
1484
1485;;;===========================================================================
1486;;;
1487;;; Standard environments:
1488;;;
1489;;;===========================================================================
1490
1491(install-expanders)
1492
1493(define scheme-tokens '( 
1494                        ;; R5RS Scheme minus macros and literals:
1495                       
1496                        * 
1497                        + 
1498                        - 
1499                        ;; ...
1500                        / 
1501                        < 
1502                        <= 
1503                        = 
1504                        ;; =>   
1505                        > 
1506                        >= 
1507                        abs 
1508                        acos 
1509                        and
1510                        append 
1511                        apply 
1512                        asin 
1513                        assoc
1514                        assq
1515                        assv
1516                        atan
1517                        begin
1518                        boolean?
1519                        caar
1520                        cadr
1521                        call-with-current-continuation
1522                        call-with-input-file
1523                        call-with-output-file
1524                        call-with-values
1525                        call/cc
1526                        case
1527                        car
1528                        cdr
1529                        caar
1530                        cadr
1531                        cdar
1532                        cddr
1533                        caaar
1534                        caadr
1535                        cadar
1536                        caddr
1537                        cdaar
1538                        cdadr
1539                        cddar
1540                        cdddr
1541                        caaaar
1542                        caaadr
1543                        caadar
1544                        caaddr
1545                        cadaar
1546                        cadadr
1547                        caddar
1548                        cadddr
1549                        cdaaar
1550                        cdaadr
1551                        cdadar
1552                        cdaddr
1553                        cddaar
1554                        cddadr
1555                        cdddar
1556                        cddddr
1557                        ceiling
1558                        char->integer
1559                        char-alphabetic?
1560                        char-ci<=?
1561                        char-ci<?
1562                        char-ci=?
1563                        char-ci>=?
1564                        char-ci>?
1565                        char-downcase
1566                        char-lower-case?
1567                        char-numeric?
1568                        char-ready?
1569                        char-upcase
1570                        char-upper-case?
1571                        char-whitespace?
1572                        char<=?
1573                        char<?
1574                        char=?
1575                        char>=?
1576                        char>?
1577                        char?
1578                        close-input-port
1579                        close-output-port
1580                        complex?
1581                        cond
1582                        cons
1583                        cos
1584                        current-input-port
1585                        current-output-port
1586                        define
1587                        ;; define-syntax
1588                        delay
1589                        denominator
1590                        display
1591                        do
1592                        dynamic-wind
1593                        ;; else           
1594                        eof-object?
1595                        eq?
1596                        equal?
1597                        eqv?
1598                        error
1599                        eval
1600                        even?
1601                        exact->inexact
1602                        exact?
1603                        exp
1604                        expt
1605                        floor
1606                        for-each
1607                        force
1608                        gcd
1609                        if
1610                        imag-part
1611                        inexact->exact
1612                        inexact?
1613                        input-port?
1614                        integer->char
1615                        integer?
1616                        interaction-environment
1617                        lambda
1618                        lcm
1619                        length
1620                        let
1621                        let*
1622                        ;; let-syntax
1623                        letrec
1624                        ;; letrec-syntax
1625                        list
1626                        list->string
1627                        list->vector
1628                        list-ref
1629                        list-tail
1630                        list?
1631                        load
1632                        location
1633                        log
1634                        magnitude
1635                        make-polar
1636                        make-rectangular
1637                        make-string
1638                        make-vector
1639                        map
1640                        max
1641                        member
1642                        memq
1643                        memv
1644                        min
1645                        modulo
1646                        negative?
1647                        newline
1648                        not
1649                        null-environment
1650                        null?
1651                        number->string
1652                        number?
1653                        numerator
1654                        odd?
1655                        open-input-file
1656                        open-output-file
1657                        or
1658                        output-port?
1659                        pair?
1660                        peek-char
1661                        port?
1662                        positive?
1663                        procedure?
1664                        quasiquote
1665                        quote
1666                        quotient
1667                        rational?
1668                        rationalize
1669                        read
1670                        read-char
1671                        real-part
1672                        real?
1673                        remainder
1674                        reverse
1675                        round
1676                        scheme-report-environment
1677                        set!
1678                        set-car!
1679                        set-cdr!
1680                        sin
1681                        sqrt
1682                        string
1683                        string->list
1684                        string->number
1685                        string->symbol
1686                        string-append
1687                        string-ci<=?
1688                        string-ci<?
1689                        string-ci=?
1690                        string-ci>=?
1691                        string-ci>?
1692                        string-copy
1693                        string-fill!
1694                        string-length
1695                        string-ref
1696                        string-set!
1697                        string<=?
1698                        string<?
1699                        string=?
1700                        string>=?
1701                        string>?
1702                        string?
1703                        substring
1704                        symbol->string
1705                        symbol?
1706                        ;; syntax-rules
1707                        tan
1708                        transcript-off
1709                        transcript-on
1710                        truncate
1711                        ;; unquote
1712                        ;; unquote-splicing
1713                        values
1714                        vector
1715                        vector->list
1716                        vector-fill!
1717                        vector-length
1718                        vector-ref
1719                        vector-set!
1720                        vector?
1721                        with-input-from-file
1722                        with-output-to-file
1723                        write
1724                        write-char
1725                        zero?
1726                       
1727                        ;; Additions for macros and libraries:
1728                       
1729                        define-syntax
1730                        let-syntax
1731                        letrec-syntax
1732                        set-syntax!
1733                       
1734                        syntax
1735                        quasisyntax
1736                        embedded-syntax
1737                        identifier?
1738                        bound-identifier=?
1739                        free-identifier=?
1740                        literal-identifier=?
1741                       
1742                        make-capturing-identifier
1743                        datum->syntax-object       
1744                        syntax-object->datum
1745                       
1746                        begin-for-syntax
1747                        around-syntax
1748                        syntax-error
1749                       
1750                        library   
1751                        import
1752                        export
1753                        indirect-export
1754                        import-primitives
1755                        ))
1756
1757(define (make-empty-env) (reflect-environment '()))
1758
1759(define make-scheme-env
1760  (let ((env (map (lambda (name) 
1761                    (cons name `((all . ,name))))   
1762                  scheme-tokens)))
1763    (lambda ()
1764      (reflect-environment env))))
1765
1766(define scheme-library (kffd:make-library "scheme://srfi-72"
1767                                     (map (lambda (token) (cons token token))
1768                                          scheme-tokens))) 
1769
1770(kffd:*loaded-libraries* '())
1771
1772(define (|library#scheme://srfi-72| mode)
1773  (case mode
1774    ((unbind) (void))
1775    (else
1776     (kffd:*loaded-libraries* (alist-cons `(scheme://srfi-72 ,mode ,(kffd:*phase*))
1777                                          scheme-library
1778                                          (kffd:*loaded-libraries*))))))
1779
1780
1781;;; Creating libraries for builtins on the fly:
1782
1783(define (kffd:register-primitive-library name symbols #!optional init?)
1784  (let* ((entry (kffd:make-library name 
1785                                 (map (lambda (token) (if (pair? token) 
1786                                                          token 
1787                                                          (cons token token))) 
1788                                      symbols)))
1789         (sname (string->symbol name)))
1790    (lambda (mode)
1791      (case mode
1792        ((unbind) (void))
1793        (else
1794         (kffd:*loaded-libraries* (alist-cons `(,sname ,mode ,(kffd:*phase*))
1795                                              entry 
1796                                              (kffd:*loaded-libraries*))))))))
1797
1798
1799;;;==========================================================================
1800;;;
1801;;; Debugging facilities:
1802;;;
1803;;;==========================================================================
1804
1805;; Displays a syntax object in human-readable format:
1806
1807(define (syntax-debug stx)
1808  (sexp-map (lambda (leaf)
1809              (if (identifier? leaf)
1810                  (symbolic-name leaf)
1811                  leaf))
1812            stx))
1813
1814(define (syntax-error . args)
1815  (newline)
1816  (display "Syntax error:")
1817  (newline) (newline)
1818  (for-each (lambda (arg)
1819              (display (syntax-debug arg)) (display " "))
1820            args)
1821  (newline) (newline)
1822  (display "In source context:")
1823  (newline) (newline)
1824  (for-each (lambda (exp)
1825              (display "  ") 
1826              (write (syntax-debug exp))
1827              (newline) (newline))
1828            (*backtrace*))
1829  (error "Expansion stopped"))
1830
1831
1832;;;============================================================================
1833;;;
1834;;; Compiler and REPL integration:
1835;;;
1836;;;============================================================================
1837
1838;; The procedure make-expander can be integrated with the host REPL and
1839;; compiler.  The result of (make-expander) takes a sequence of source-phase
1840;; s-expressions and expands it to a sequence of core Scheme expressions that
1841;; can be either compiled or fed to eval. 
1842
1843;; To compile a file separately, invoke (make-expander) to make an
1844;; expander with a clean environment.  A single invocation of the result
1845;; of (make-expander) will expand the sequence of expressions to core
1846;; Scheme.
1847
1848;; For REPL use, reuse a single expander for subsequent evaluations
1849;; to ensure continuity of toplevel bindings. 
1850
1851;; Each time an expander is reinvoked, a new renaming procedure
1852;; is used, taking its initial toplevel binding environment from
1853;; the previous invocation of the same expander.  We could have reused the
1854;; same renaming procedure, but since the hygiene algorithm destructively
1855;; updates bindings, we would have had to guard against inconsistent states
1856;; in case an error occurred during expansion (relevant in a typical toplevel
1857;; debugging cycle where the system is not necessarily reinitialized after
1858;; each error). 
1859;; As a result, identifiers with the same symbolic name in
1860;; separate toplevel expressions are not guaranteed to be
1861;; bound-identifier=?  This is not a serious restriction.   
1862
1863
1864(define (make-expander)
1865  (let ((source-rename (make-renaming-procedure 0 source-colour (make-scheme-env) #f)))
1866    (lambda (exps)
1867      (*backtrace*                '())
1868      (kffd:*current-library-name* "")
1869      (*in-syntax*                #f)
1870      (kffd:*phase*               0)
1871      (set! source-rename
1872            (make-renaming-procedure 0
1873                                     source-colour 
1874                                     ;; This copies the toplevel binding environment
1875                                     ;; from the previous invocation.
1876                                     (close-environment (source-rename 'dummy))
1877                                     #f))
1878      (map-in-order expand (datum->syntax source-rename exps)))))
1879
1880
1881;; This may be used to simulate a REPL in the meantime.
1882
1883;; Due to the syntactic tower, we have the nice property that
1884;;
1885;; (for-each eval (expand-toplevel (list exp ...)))
1886;;     == (for-each (lambda (exp)
1887;;                    (eval (expand-toplevel (list exp)))))
1888;;
1889;; In other words, it doesn't matter whether we expand the whole
1890;; sequence first and then evaluate or expand and evaluate one by one.   
1891
1892
1893(define kffd:eval
1894  (let ((old (##sys#eval-handler))) 
1895    (lambda (x . _)
1896      #+debug (pp `(EVAL: ,x))
1897      (old x)) ) )
1898
1899;(define repl
1900;  (let ((expand-toplevel (make-expander)))
1901;    (lambda (exps)         
1902;      (for-each (lambda (exp)
1903;                  (for-each (lambda (result)
1904;                              (display result)
1905;                              (newline))
1906;                            (call-with-values
1907;                             (lambda ()
1908;                               (kffd:eval (car (expand-toplevel (list exp)))))                       
1909;                             list)))
1910;                exps))))
1911
1912
1913;;;=========================================================================
1914;;;
1915;;; The usual macros:                                                   
1916;;;
1917;;;=========================================================================
1918
1919;; Here we need to redefine all binding forms of the host Scheme.
1920;; We also need to redefine all forms that treat parts of their body
1921;; as literals.   
1922
1923
1924;; Expands a sequence of expressions using primitive renaming procedure
1925;; so that we can have access to primitives above without needing to import
1926;; things.
1927
1928(define (primitive-expand exps)                     
1929  (let ((rename (make-primitive-renaming-procedure))) 
1930    (map-in-order expand 
1931                  (datum->syntax rename exps))))
1932
1933
1934;; For a production system, instead of eval, the following can be replaced
1935;; by the result of primitive-expand, which can then be compiled with the
1936;; rest of the file.
1937
1938(for-each
1939 kffd:eval 
1940 (primitive-expand 
1941  '(                           
1942   
1943    (define-syntax let
1944      (lambda (t)
1945        (if (and (pair? t)
1946                 (pair? (cdr t))
1947                 (identifier? (cadr t)))
1948            (kffd:scan-let (cons (car t) (cddr t))
1949                           (lambda (formals exps body)
1950                             (quasisyntax
1951                              ((letrec ((,(cadr t) (lambda ,formals ,@body))) ,(cadr t))
1952                               ,@exps))))
1953            (kffd:scan-let t
1954                           (lambda (formals exps body)
1955                             (quasisyntax
1956                              ((lambda ,formals ,@body) ,@exps)))))))
1957   
1958   
1959    (define-syntax letrec
1960      (lambda (t)
1961        (kffd:scan-let t
1962                       (lambda (formals exps body)
1963                         (let ((definitions (map (lambda (formal exp)
1964                                                   (quasisyntax (define ,formal ,exp)))
1965                                                 formals
1966                                                 exps)))
1967                           (quasisyntax ((lambda () ,@definitions ,@body))))))))
1968   
1969   
1970    (define-syntax let*
1971      (lambda (t)
1972        (kffd:scan-let t
1973                       (lambda (formals exps body)
1974                         (let ((bindings (cadr t)))
1975                           (if (or (null? bindings)
1976                                   (null? (cdr bindings)))
1977                               (quasisyntax (let ,bindings ,@body))
1978                               (quasisyntax (let (,(car bindings))
1979                                              (let* ,(cdr bindings) ,@body)))))))))
1980   
1981   
1982    (define-syntax (cond . clauses)
1983      (if (null? clauses)
1984          (syntax-error  "Cond: Must have at least one clause"))
1985      (car
1986       (let f ((clauses clauses))
1987         (if (null? clauses)
1988             '()
1989             (list
1990              (if (pair? clauses)
1991                  (let ((clause (car clauses))
1992                        (rest   (f (cdr clauses))))
1993                    (if (or (null? clause)
1994                            (not (list? clause)))
1995                        (syntax-error "Cond: Invalid clause"
1996                                      clause))
1997                    (if (and (literal-identifier=? (car clause) (syntax else))
1998                             (null? rest))
1999                        (quasisyntax (begin ,@(cdr clause)))
2000                        (if (null? (cdr clause)) 
2001                            (quasisyntax (let ((t ,(car clause)))
2002                                           (if t t ,@rest)))
2003                            (if (and (literal-identifier=? (cadr clause) (syntax =>))
2004                                     (pair? (cddr clause))
2005                                     (null? (cdddr clause)))
2006                                (quasisyntax (let ((t ,(car clause)))
2007                                               (if t (,(caddr clause) t) ,@rest)))
2008                                (if (and (list? clause) (eq? 4 (length clause))
2009                                         (literal-identifier=? (caddr clause) (syntax =>)) )
2010                                    (quasisyntax
2011                                     (##sys#call-with-values
2012                                      (lambda () ,(car clause))
2013                                      (lambda t
2014                                        (if (##sys#apply ,(cadr clause) t)
2015                                            (##sys#apply ,(cadddr clause) t)
2016                                            ,@rest) ) ) )
2017                                    (quasisyntax (if ,(car clause)
2018                                                     (begin ,@(cdr clause))
2019                                                     ,@rest)))))) )
2020                  (syntax-error)))))))
2021   
2022   
2023    (define-syntax (case . rest)
2024      (or (pair? rest)
2025          (syntax-error))
2026      (let ((key (car rest))
2027            (temp (syntax temp))
2028            (clauses (cdr rest)))
2029        (or (list? clauses)
2030            (syntax-error))
2031        (quasisyntax
2032         (let ((,temp ,key))
2033           (cond
2034             ,@(map (lambda (clause)
2035                      (or (pair? clause)
2036                          (syntax-error "Case: Invalid clause:"
2037                                        clause))
2038                      (quasisyntax
2039                       (,(cond ((literal-identifier=? (car clause) (syntax else))
2040                                (car clause))
2041                               ((list? (car clause))
2042                                (quasisyntax (memv ,temp ',(car clause))))
2043                               (else
2044                                (syntax-error "Case: Invalid literals list:"
2045                                              (car clause))))
2046                         ,@(cdr clause))))
2047                    clauses))))))
2048   
2049   
2050    (define-syntax do
2051      (lambda (exp)
2052        (or (and (pair? (cdr exp))
2053                 (pair? (cddr exp)))
2054            (syntax-error))
2055        (let ((specs (cadr exp))
2056              (end (caddr exp))
2057              (body (cdddr exp))
2058              (loop (syntax loop)))
2059          (or (and (list? specs)
2060                   (kffd:every? do-spec? specs)
2061                   (list? end))
2062              (syntax-error))
2063          (quasisyntax
2064           (letrec ((,loop
2065                      (lambda ,(map car specs)
2066                        (cond ,end
2067                              (else ,@body
2068                                    (,loop
2069                                      ,@(map (lambda (spec)
2070                                               (if (null? (cddr spec))
2071                                                   (car spec)
2072                                                   (caddr spec)))
2073                                             specs)))))))
2074             (,loop ,@(map cadr specs)))))))
2075   
2076   
2077    (define (do-spec? s)                       
2078      (and (pair? s)
2079           (identifier? (car s))
2080           (pair? (cdr s))
2081           (let ((rest (cddr s)))
2082             (or (null? rest)
2083                 (and (pair? rest)
2084                      (null? (cdr rest)))))))
2085   
2086    ;; R6RS library support:
2087
2088    (define-syntax export
2089      (lambda (form)
2090        (let ((x-sets (cdr form)))
2091          (or (and (list? x-sets)
2092                   (andmap export-set? x-sets))
2093            (syntax-error "Export: Invalid syntax:" form))
2094        (let loop ((x-sets x-sets)
2095                   (exports '()))
2096          (if (null? x-sets)
2097              (quasisyntax (export-0 ,@exports))
2098              (let ((x-set (car x-sets)))
2099                (if (identifier? x-set)
2100                    (loop (cdr x-sets)
2101                          (cons (list x-set x-set)
2102                                exports))
2103                    (let ((renames (cdr x-set)))
2104                      (loop (cdr x-sets)
2105                            (append (map reverse renames) exports))))))))))
2106
2107         
2108    (define (export-set? x)
2109      (or (identifier? x)
2110          (and (list? x)
2111               (not (null? x))
2112               (literal-identifier=? (car x) (syntax rename))
2113               (andmap (lambda (e)
2114                         (and (list? e)
2115                              (= (length e) 2)
2116                              (andmap identifier? e)))
2117                       (cdr x)))))
2118   
2119     
2120    (define-syntax indirect-export
2121      (lambda (form)
2122        (or (and (list? (cdr form))
2123                 (andmap indirect-spec? (cdr form)))
2124            (syntax-error "Indirect-export: Invalid syntax:" form))
2125        (quasisyntax 
2126         (export ,@(apply append (map cdr (cdr form)))))))
2127   
2128    (define (indirect-spec? e)
2129      (and (list? e)
2130           (>= (length e) 1)
2131           (andmap identifier? e)))
2132
2133   
2134
2135    (define-syntax import
2136      (lambda (form)
2137        (or (and (list? (cdr form))
2138                 (andmap import-spec? (cdr form)))
2139            (syntax-error "Import: Invalid syntax:" form))
2140        (quasisyntax
2141         (begin
2142           ,@(map (lambda (spec)
2143                    (translate-import-spec (car form) spec))
2144                  (cdr form))))))
2145
2146    ;; Here k is the source-level |import| keyword, which determines
2147    ;; the hygienic context into which the imports are inserted.
2148   
2149    (define (translate-import-spec k e . maybe-all)
2150      (cond ((for? e)
2151             (quasisyntax
2152              (begin ,@(map (lambda (phase)
2153                              (let loop ((phase phase))
2154                                (cond ((literal-identifier=? phase (syntax run))    (loop 0))
2155                                      ((literal-identifier=? phase (syntax expand)) (loop 1))
2156                                      ((literal-identifier=? phase (syntax all)) 
2157                                       (translate-import-spec k (cadr e) (syntax all)))
2158                                      ((= phase 0) 
2159                                       (translate-import-spec k (cadr e)))
2160                                      (else
2161                                       (quasisyntax
2162                                        (begin-for-syntax ,(loop (- phase 1))))))))
2163                            (cddr e)))))
2164            (else
2165             ;; e is import-set
2166             (let loop ((e e)
2167                        (rename (quasisyntax (lambda (x) x))))
2168               (if (lib-path? e) 
2169                   (quasisyntax (import-0 ,k ,e ,rename . ,maybe-all))
2170                   (loop (cadr e)
2171                         (quasisyntax
2172                          (lambda (x)
2173                            (,rename
2174                             ,(cond
2175                               ((literal-identifier=? (car e) (syntax only))
2176                                (quasisyntax
2177                                 (if (memv x ',(cddr e))
2178                                     x
2179                                     #f)))
2180                               ((literal-identifier=? (car e) (syntax except))
2181                                (quasisyntax
2182                                 (if (not (memv x ',(cddr e)))
2183                                     x
2184                                     #f)))
2185                               ((literal-identifier=? (car e) (syntax add-prefix))
2186                                (quasisyntax
2187                                 (if x
2188                                     (string->symbol
2189                                      (string-append (kffd:symbol->prefix-string ',(caddr e))
2190                                                     (symbol->string x)))
2191                                     #f)))
2192                               ((literal-identifier=? (car e) (syntax rename))
2193                                (quasisyntax
2194                                 (case x
2195                                   ,@(map (lambda (old+new)
2196                                            (quasisyntax
2197                                             ((,(car old+new)) ',(cdr old+new))))
2198                                          (cddr e))
2199                                   (else x))))))))))))))
2200                                               
2201
2202    (define (import-spec? e)
2203      (or (import-set? e)
2204          (for? e)))
2205
2206    (define (import-set? e)
2207      (or (lib-path? e)
2208          (and (pair? e)
2209               (or (and (or (literal-identifier=? (car e) (syntax only))
2210                            (literal-identifier=? (car e) (syntax except)))
2211                        (list? e)
2212                        (>= (length e) 2)
2213                        (import-set? (cadr e))
2214                        (andmap identifier? (cddr e)))
2215                   (and (literal-identifier=? (car e) (syntax add-prefix))
2216                        (list? e)
2217                        (= (length e) 3)
2218                        (import-set? (cadr e))
2219                        (identifier? (caddr e)))
2220                   (and (literal-identifier=? (car e) (syntax rename))
2221                        (list? e)
2222                        (>= (length e) 2)
2223                        (import-set? (cadr e))
2224                        (andmap (lambda (e)
2225                                  (and (list? e)
2226                                       (= (length e) 2)
2227                                       (andmap identifier? e)))
2228                                (cddr e)))))))
2229
2230    (define (lib-path? e)
2231      (string? e))
2232                                     
2233    (define (for? e)
2234      (and (list? e)
2235           (>= (length e) 2)
2236           (literal-identifier=? (car e) (syntax for))
2237           (import-set? (cadr e))
2238           (andmap import-phase? (cddr e))))
2239
2240    (define (import-phase? e)
2241      (or (literal-identifier=? e (syntax run))
2242          (literal-identifier=? e (syntax expand))
2243          (literal-identifier=? e (syntax all))
2244          (and (integer? e)
2245               (>= e 0))))
2246
2247     
2248    (define-syntax import-primitives
2249      (lambda (form)
2250        (expand-import-primitives form)))
2251
2252    (define-syntax import-primitives-for-all
2253      (lambda (form)
2254        (expand-import-primitives form 'all)))
2255
2256    (define expand-import-primitives
2257      (lambda (form . maybe-phase)
2258        (or (and (list? (cdr form))
2259                 (kffd:every? identifier? (cdr form)))
2260            (syntax-error))
2261        (let ((k     (car form))
2262              (names (map syntax-object->datum (cdr form))))
2263          (for-each (lambda (name)
2264                      (apply kffd:import! name name k maybe-phase))
2265                    names)
2266          (syntax (void)))))
2267
2268    ))) ; REPL
2269
2270
2271(define |library#chicken://chicken-internals|
2272  (kffd:register-primitive-library
2273   "chicken://chicken-internals"
2274   '(##core#declare ##core#require-extension ##sys#resolve-include-filename
2275                    ##sys#setslot ##core#inline ##core#inline_allocate
2276                    read-file when unless assert ensure time :optional critical-section
2277                    nth-value setter ##sys#setter kffd:register-primitive-library
2278                    add1 sub1 bitwise-and bitwise-ior bitwise-xor bitwise-not
2279                    arithmetic-shift fixnum? fx+ fx- fx* fx/ fx> fx< fx>= fx=
2280                    fx<= fxand fxior fxxor fxnot fxmod fxmin fxmax fxneg
2281                    fxshl fxshr fp+ fp- fp* fp/ fpneg gpmax fpmin fp= fp> fp< fp>= fp<=
2282                    signum current-error-port end-of-file flush-output port-name
2283                    port-position set-port-name! delete-file file-exists?
2284                    pathname-directory-separator rename-file get-output-string
2285                    open-output-string open-input-string features feature?
2286                    register-feature! unregister-feature! get-keyword keyword->string
2287                    string->keyword make-property-condition ##sys#get-keyword
2288                    make-composite-condition condition-predicate condition?
2289                    condition-property-accessor current-exception-handler procedure-information
2290                    with-exception-handler abort signal argv make-parameter
2291                    exit build-platform chicken-version errno getenv machine-type
2292                    software-type software-version c-runtime chicken-home system
2293                    cpu-time current-milliseconds current-seconds enable-interrupts
2294                    disable-interrupts enable-warnings error print-backtrace
2295                    case-sensitive
2296                    print-error-message reset gc memory-statistics set-finalizer!
2297                    set-gc-report! andmap ormap reverse-list->string gensym
2298                    string->uninterned-symbol port? print print* char-name
2299                    vector-copy! vector-resize void call/cc continuation-capture
2300                    continuation? continuation-graft continuation-return
2301                    load-library load-noisily set-dynamic-load-mode! repl
2302                    get-line-number macro? macroexpand macroexpand-1 promise?
2303                    undefine-macro! repository-path extension-info provide
2304                    require require-for-syntax provided? set-extension-specifier!
2305                    define-reader-ctor set-read-syntax! ##sys#require
2306                    ##core#define-foreign-type ##core#define-foreign-variable
2307                    ##core#foreign-lambda ##core#foreign-lambda* ##core#foreign-callback-lambda
2308                    ##core#foreign-callback-lambda* ##core#foreign-primitive
2309                    ##core#foreign-callback-wrapper ##core#let-location ##core#define-constant
2310                    foreign-code foreign-value ##compiler#foreign-type-declaration
2311                    ##sys#list ##sys#call-with-values ##sys#start-timer
2312                    ##sys#stop-timer ##sys#apply ##sys#values ##sys#display-times
2313                    ##core#immutable ##core#check ##core#undefined ##sys#error
2314                    ##sys#string->qualified-symbol ##sys#qualified-symbol-prefix
2315                    ##sys#make-structure ##sys#structure? ##sys#check-structure
2316                    ##sys#block-ref ##sys#block-set! ##sys#dynamic-wind
2317                    ##core#set! ##sys#map ##core#compiletimetoo ##core#compiletimeonly
2318                    ##sys#check-syntax ##sys#disable-interrupts ##sys#enable-interrupts
2319                    ##sys#register-record-printer ##sys#signal ##sys#slot 
2320                    ##core#global-ref ##sys#void ##core#require-for-syntax 
2321                    cond-expand) ) )
2322
2323(kffd:*loaded-libraries* 
2324 (alist-cons `(chicken://chicken-internals visited all) |library#chicken://chicken-internals|
2325             (kffd:*loaded-libraries*) ) )
2326
2327(kffd:*loaded-libraries* 
2328 (alist-cons `(chicken://chicken-internals invoked all) |library#chicken://chicken-internals|
2329             (kffd:*loaded-libraries*) ) )
2330
2331(define kffd:expand 
2332  (let ((expand-toplevel (make-expander)))
2333    (lambda (exp)
2334      #+debug (pp `(EXPAND: ,(feature? 'compiling) 
2335                            ,(syntax-debug exp)))
2336      (let ((result (car (expand-toplevel (list exp)))))
2337        #+debug (pp `(------> ,result))
2338        result))))
2339
2340
2341(define (kffd:install)
2342  (let ((old macroexpand))
2343    (set! macroexpand (lambda (exp . me) (old (kffd:expand exp)))) )
2344 
2345  ;; AvT:  Begin-for-syntax is now handled specially by the expander
2346 
2347  ;; (##sys#register-macro-2
2348  ;; 'begin-for-syntax
2349  ;; (lambda (body)
2350  ;;   `(##core#elaborationtimeonly ,(cons 'begin body)) ) )
2351 
2352  (set! ##sys#compiler-toplevel-macroexpand-hook kffd:expand)
2353 
2354  ;; AvT:  Should be unnecessary now
2355 
2356  ;;      (lambda (form)
2357  ;;        (let loop ((form (kffd:expand (cons 'begin (flatten-begins (list form))))))
2358  ;;          (match form
2359  ;;            (('begin body ...) `(begin ,@(map loop body)))
2360  ;;            (('kffd:register-macro . _)
2361  ;;             (kffd:eval form)
2362  ;;             '(##sys#void) )
2363  ;;            (_ form) ) ) ) )
2364 
2365  (set! ##sys#interpreter-toplevel-macroexpand-hook kffd:expand))
2366
2367(kffd:install)
2368
2369(define |library#scheme://chicken|)             ; set in following eval
2370
2371(eval
2372 
2373 '(library "scheme://chicken" "scheme://srfi-72"
2374           (export declare require-extension use ##core#declare ##sys#require ##sys#setter setter
2375                   add1 sub1 bitwise-and bitwise-ior bitwise-xor bitwise-not
2376                           arithmetic-shift fixnum? fx+ fx- fx* fx/ fx> fx< fx>= fx=
2377                           fx<= fxand fxior fxxor fxnot fxmod fxmin fxmax fxneg
2378                           fxshl fxshr fp+ fp- fp* fp/ fpneg gpmax fpmin fp= fp> fp< fp>= fp<=
2379                           signum current-error-port end-of-file flush-output port-name
2380                           port-position set-port-name! delete-file file-exists?
2381                           pathname-directory-separator rename-file get-output-string
2382                           open-output-string open-input-string features feature?
2383                           register-feature! unregister-feature! get-keyword keyword->string
2384                           string->keyword make-property-condition make-parameter
2385                           when unless require-library ##sys#get-keyword
2386                           make-composite-condition condition-predicate condition?
2387                           condition-property-accessor current-exception-handler
2388                           with-exception-handler abort signal argv procedure-information
2389                           exit build-platform chicken-version errno getenv machine-type
2390                           software-type software-version c-runtime chicken-home system
2391                           cpu-time current-milliseconds current-seconds enable-interrupts
2392                           disable-interrupts enable-warnings error print-backtrace
2393                           print-error-message reset gc memory-statistics set-finalizer!
2394                           set-gc-report! andmap ormap reverse-list->string gensym
2395                           string->uninterned-symbol port? print print* char-name
2396                           vector-copy! vector-resize void call/cc continuation-capture
2397                           continuation? continuation-graft continuation-return
2398                           load-library load-noisily set-dynamic-load-mode! repl
2399                           get-line-number macro? macroexpand macroexpand-1
2400                           undefine-macro! repository-path extension-info provide
2401                           require require-for-syntax provided? set-extension-specifier!
2402                           set-dispatch-read-syntax! promise? define-for-syntax
2403                           define-reader-ctor set-read-syntax! cond-expand
2404                        ;; R5RS Scheme minus macros and literals:
2405                       
2406                        * 
2407                        + 
2408                        - 
2409                        ;; ...
2410                        / 
2411                        < 
2412                        <= 
2413                        = 
2414                        ;; =>   
2415                        > 
2416                        >= 
2417                        abs 
2418                        acos 
2419                        and
2420                        append 
2421                        apply 
2422                        asin 
2423                        assoc
2424                        assq
2425                        assv
2426                        atan
2427                        begin
2428                        boolean?
2429                        caar
2430                        cadr
2431                        call-with-current-continuation
2432                        call-with-input-file
2433                        call-with-output-file
2434                        call-with-values
2435                        call/cc
2436                        case
2437                        car
2438                        cdr
2439                        caar
2440                        cadr
2441                        cdar
2442                        cddr
2443                        caaar
2444                        caadr
2445                        cadar
2446                        caddr
2447                        cdaar
2448                        cdadr
2449                        cddar
2450                        cdddr
2451                        caaaar
2452                        caaadr
2453                        caadar
2454                        caaddr
2455                        cadaar
2456                        cadadr
2457                        caddar
2458                        cadddr
2459                        cdaaar
2460                        cdaadr
2461                        cdadar
2462                        cdaddr
2463                        cddaar
2464                        cddadr
2465                        cdddar
2466                        cddddr
2467                        ceiling
2468                        char->integer
2469                        char-alphabetic?
2470                        char-ci<=?
2471                        char-ci<?
2472                        char-ci=?
2473                        char-ci>=?
2474                        char-ci>?
2475                        char-downcase
2476                        char-lower-case?
2477                        char-numeric?
2478                        char-ready?
2479                        char-upcase
2480                        char-upper-case?
2481                        char-whitespace?
2482                        char<=?
2483                        char<?
2484                        char=?
2485                        char>=?
2486                        char>?
2487                        char?
2488                        close-input-port
2489                        close-output-port
2490                        complex?
2491                        cond
2492                        cons
2493                        cos
2494                        current-input-port
2495                        current-output-port
2496                        define
2497                        ;; define-syntax
2498                        delay
2499                        denominator
2500                        display
2501                        do
2502                        dynamic-wind
2503                        ;; else           
2504                        eof-object?
2505                        eq?
2506                        equal?
2507                        eqv?
2508                        error
2509                        eval
2510                        even?
2511                        exact->inexact
2512                        exact?
2513                        exp
2514                        expt
2515                        floor
2516                        for-each
2517                        force
2518                        gcd
2519                        if
2520                        imag-part
2521                        inexact->exact
2522                        inexact?
2523                        input-port?
2524                        integer->char
2525                        integer?
2526                        interaction-environment
2527                        lambda
2528                        lcm
2529                        length
2530                        let
2531                        let*
2532                        ;; let-syntax
2533                        letrec
2534                        ;; letrec-syntax
2535                        list
2536                        list->string
2537                        list->vector
2538                        list-ref
2539                        list-tail
2540                        list?
2541                        load
2542                        location
2543                        log
2544                        magnitude
2545                        make-polar
2546                        make-rectangular
2547                        make-string
2548                        make-vector
2549                        map
2550                        max
2551                        member
2552                        memq
2553                        memv
2554                        min
2555                        modulo
2556                        negative?
2557                        newline
2558                        not
2559                        null-environment
2560                        null?
2561                        number->string
2562                        number?
2563                        numerator
2564                        odd?
2565                        open-input-file
2566                        open-output-file
2567                        or
2568                        output-port?
2569                        pair?
2570                        peek-char
2571                        port?
2572                        positive?
2573                        procedure?
2574                        quasiquote
2575                        quote
2576                        quotient
2577                        rational?
2578                        rationalize
2579                        read
2580                        read-char
2581                        real-part
2582                        real?
2583                        remainder
2584                        reverse
2585                        round
2586                        scheme-report-environment
2587                        set!
2588                        set-car!
2589                        set-cdr!
2590                        sin
2591                        sqrt
2592                        string
2593                        string->list
2594                        string->number
2595                        string->symbol
2596                        string-append
2597                        string-ci<=?
2598                        string-ci<?
2599                        string-ci=?
2600                        string-ci>=?
2601                        string-ci>?
2602                        string-copy
2603                        string-fill!
2604                        string-length
2605                        string-ref
2606                        string-set!
2607                        string<=?
2608                        string<?
2609                        string=?
2610                        string>=?
2611                        string>?
2612                        string?
2613                        substring
2614                        symbol->string
2615                        symbol?
2616                        ;; syntax-rules
2617                        tan
2618                        transcript-off
2619                        transcript-on
2620                        truncate
2621                        ;; unquote
2622                        ;; unquote-splicing
2623                        values
2624                        vector
2625                        vector->list
2626                        vector-fill!
2627                        vector-length
2628                        vector-ref
2629                        vector-set!
2630                        vector?
2631                        with-input-from-file
2632                        with-output-to-file
2633                        write
2634                        write-char
2635                        zero?
2636                       
2637                        ;; Additions for macros and libraries:
2638                       
2639                        define-syntax
2640                        let-syntax
2641                        letrec-syntax
2642                        set-syntax!
2643                       
2644                        syntax
2645                        quasisyntax
2646                        embedded-syntax
2647                        identifier?
2648                        bound-identifier=?
2649                        free-identifier=?
2650                        literal-identifier=?
2651                       
2652                        make-capturing-identifier
2653                        datum->syntax-object       
2654                        syntax-object->datum
2655                       
2656                        begin-for-syntax
2657                        around-syntax
2658                        syntax-error
2659                       
2660                        library   
2661                        import
2662                        export
2663                        indirect-export
2664                        import-primitives)
2665   
2666           (import (for "chicken://chicken-internals" all))
2667   
2668    (begin-for-syntax 
2669     
2670      (define (quotify lst)
2671        (map (lambda (x) #`(quote ,x)) lst))
2672     
2673      ) ; begin-for-syntax
2674   
2675    (define-syntax (cond-expand . clauses)
2676      (if (null? clauses)
2677          (error "no matching clause in `cond-expand' form")
2678          (let ((clause (car clauses))
2679                (more (cdr clauses)) )
2680            (if (not (pair? clause))
2681                (syntax-error "invalid clause in `cond-expand' form" (syntax-debug clause))
2682                (let ((head (car clause))
2683                      (body (cdr clause)) )
2684                  (cond ((literal-identifier=? head #'else)
2685                         #`(begin ,@(cdr clause)) )
2686                        ((not (pair? head))
2687                         (if (feature? (syntax-object->datum head))
2688                             #`(begin ,@body)
2689                             #`(cond-expand ,@more) ) )
2690                        (else
2691                         (let ((hh (car head))
2692                               (hr (cdr head)) )
2693                           (cond ((literal-identifier=? hh #'and)
2694                                  (if (null? hr)
2695                                      #`(begin ,@body)
2696                                      #`(cond-expand
2697                                         (,(car hr)
2698                                           (cond-expand 
2699                                            ((and ,@(cdr hr)) ,@body)
2700                                            ,@more) )
2701                                         ,@more) ) )
2702                                 ((literal-identifier=? hh #'or)
2703                                  (if (null? hr)
2704                                      #`(cond-expand ,@more)
2705                                      #`(cond-expand
2706                                         (,(car hr)
2707                                           (begin ,@body) )
2708                                         (else
2709                                          (cond-expand
2710                                           ((or ,@(cdr hr)) ,@body)
2711                                           ,@more) ) ) ) )
2712                                 ((literal-identifier=? hh #'not)
2713                                  #`(cond-expand
2714                                     (,(car hr) (cond-expand ,@more))
2715                                     (else ,@body) ) )
2716                                 (else (syntax-error "invalid clause in `cond-expand' form"
2717                                                     (syntax-debug clause)) ) ) ) ) ) ) ) ) ) )
2718   
2719    (define-syntax (require-library . names)
2720      #`(begin
2721          ,@(map (lambda (n) 
2722                   (require (syntax-object->datum n))
2723                   #`(require ',n))
2724                 names) ) )
2725
2726    (define-syntax (declare . rest)
2727      #`(##core#declare ,@(quotify rest)) )
2728   
2729    (define-syntax (require-extension . rest)
2730      #`(##core#require-extension ,@(quotify rest)))
2731   
2732    (define-syntax (use . rest)
2733      #`(require-extension ,@rest) )
2734
2735    (define-syntax (define-for-syntax . def)
2736      #`(begin-for-syntax (define ,@def) ) )
2737
2738) )
2739
2740
2741(eval '(import (for "scheme://chicken" all)))
2742
2743(register-feature! 'srfi-72)
2744
2745(when (feature? 'compiling)
2746  (set! ##compiler#literal-compression-threshold 50) )
Note: See TracBrowser for help on using the repository browser.