Changeset 10359 in project


Ignore:
Timestamp:
04/06/08 01:34:34 (12 years ago)
Author:
felix winkelmann
Message:

low-level module attempt; converted some more macros

Location:
chicken/branches/beyond-hope
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/beyond-hope/TODO

    r10352 r10359  
    11TODO for macro/module system                                    -*- Outline -*-
     2
     3* current module approach problems
     4** fixup of module export-list in ##sys#extend-macro-environment
     5   not done for static se's of global macros
    26
    37* reimplement macros from chicken-more-macros hygienically
     
    1519** extended lambda-list markers
    1620** local definitions
     21* test line-number retention over macro-expansion
    1722
    1823* test benchmarks
    1924
    2025* reimplement chicken-more-macros hygienically
     26
     27* remove define-macro and ##sys#lisp-transformer, once all macros are converted
    2128
    2229* add low-level support for modules
     
    3037*** user defined ellipsis
    3138** ack synrules authors
     39** removals
     40   define-macro
     41   define-record
     42   run-time and compile-time situations for eval-when
    3243
    3344* csi
  • chicken/branches/beyond-hope/chicken-more-macros.scm

    r10358 r10359  
    211211           (%body (r 'begin))
    212212           (body `(,%begin ,@(cddr form)))
     213           (%eval (r 'eval))
     214           (%compile (r 'compile))
     215           (%load (r 'load))
    213216           (e #f)
    214217           (c #f)
     
    216219      (let loop ([ss situations])
    217220        (if (pair? ss)
    218             (begin
    219               (case (##sys#slot ss 0)
    220                 [(eval) (set! e #t)]
    221                 [(load run-time) (set! l #t)]
    222                 [(compile compile-time) (set! c #t)]
    223                 [else (##sys#error "invalid situation specifier" (##sys#slot ss 0))] )
     221            (let ((s (car ss)))
     222              (cond ((c s %eval) (set! e #t))
     223                    ((c s %load) (set! l #t))
     224                    ((c s %compile) (set! c #t))
     225                    (else (##sys#error "invalid situation specifier" (car ss)) ))
    224226              (loop (##sys#slot ss 1)) ) ) )
    225227      (if (memq '#:compiling ##sys#features)
     
    355357                     (,%lambda ,(car llists2) ,(fold (cdr llists) (cdr exps) (cdr llists2))) ) ) ) ) ) ) ) ) ) )
    356358
    357 ;*** translate to hygienic
    358 
    359 (define-macro (let*-values vbindings . body)
    360   (let fold ([vbindings vbindings])
    361     (if (null? vbindings)
    362         `(let () ,@body)
    363         `(let-values (,(car vbindings))
    364            ,(fold (cdr vbindings))) ) ) )
    365 
    366 (define-macro (letrec-values vbindings . body)
    367   (let* ([vars (apply ##sys#append (map (lambda (x) (car x)) vbindings))]
    368          [aliases (map (lambda (v) (cons v (gensym v))) vars)]
    369          [lookup (lambda (v) (cdr (assq v aliases)))] )
    370     `(let ,(map (lambda (v) (##sys#list v '(##core#undefined))) vars)
    371         ,@(map (lambda (vb)
    372                  `(##sys#call-with-values (lambda () ,(cadr vb))
    373                     (lambda ,(map lookup (car vb))
    374                       ,@(map (lambda (v) `(##core#set! ,v ,(lookup v))) (car vb)) ) ) )
    375                vbindings)
    376         ,@body) ) )
    377 
    378 (define-macro (nth-value i exp)
    379    (let ([v (gensym)])
    380      `(##sys#call-with-values
    381        (lambda () ,exp)
    382        (lambda ,v (list-ref ,v ,i)) ) ) )
    383 
    384 (define-macro (define-inline . args)
    385   (letrec ([quotify-proc
    386             (lambda (xs id)
    387               (##sys#check-syntax id xs '#(_ 1))
    388               (let* ([head (car xs)]
    389                      [name (if (pair? head) (car head) head)]
    390                      [val (if (pair? head)
    391                               `(lambda ,(cdr head) ,@(cdr xs))
    392                               (cadr xs) ) ] )
    393                 (when (or (not (pair? val)) (not (eq? 'lambda (car val))))
    394                   (syntax-error
    395                    'define-inline "invalid substitution form - must be lambda"
    396                    name) )
    397                 (list (list 'quote name) val) ) ) ] )
    398     `(##core#define-inline ,@(quotify-proc args 'define-inline))))
    399 
    400 (define-macro (define-constant var val)
    401   `(##core#define-constant ',var ,val) )
    402 
    403 (define-macro (and-let* bindings . body)
    404   (let fold ([bs bindings])
    405     (if (null? bs)
    406         `(begin ,@body)
    407         (let ([b (##sys#slot bs 0)]
    408               [bs2 (##sys#slot bs 1)] )
    409           (cond [(not-pair? b) `(if ,b ,(fold bs2) #f)]
    410                 [(null? (##sys#slot b 1)) `(if ,(##sys#slot b 0) ,(fold bs2) #f)]
    411                 [else
    412                  (let ([var (##sys#slot b 0)])
    413                    `(let ((,var ,(cadr b)))
    414                       (if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) )
    415 
    416 (define-macro (select exp . body)
    417   (let ((tmp (gensym)))
    418     `(let ((,tmp ,exp))
    419        ,(let expand ((clauses body))
    420           (if (not (pair? clauses))
    421               '(##core#undefined)
    422               (let ((clause (##sys#slot clauses 0))
    423                     (rclauses (##sys#slot clauses 1)) )
    424                 (##sys#check-syntax 'select clause '#(_ 1))
    425                 (if (eq? 'else (car clause))
    426                     `(begin ,@(cdr clause))
    427                     `(if (or ,@(map (lambda (x) `(eqv? ,tmp ,x))
    428                                     (car clause) ) )
    429                          (begin ,@(cdr clause))
    430                          ,(expand rclauses) ) ) ) ) ) ) ) )
     359(##sys#extend-macro-environment
     360 'let*-values '()
     361 (##sys#er-transformer
     362  (lambda (form r c)
     363    (##sys#check-syntax 'let*-values form '(_ list . _))
     364    (let ((vbindings (cadr form))
     365          (body (cddr form))
     366          (%let (r 'let))
     367          (%let-values (r 'let-values)) )
     368      (let fold ([vbindings vbindings])
     369        (if (null? vbindings)
     370            `(,%let () ,@body)
     371            `(,%let-values (,(car vbindings))
     372                           ,(fold (cdr vbindings))) ) ) ))))
     373
     374(##sys#extend-macro-environment
     375 'letrec-values '()
     376 (##sys#er-transformer
     377  (lambda (form r c)
     378    (##sys#check-syntax 'letrec-values form '(_ list . _))
     379    (let ((vbindings (cadr form))
     380          (body (cddr form))
     381          (%let (r 'let))
     382          (%lambda (r 'lambda)))
     383      (let* ([vars (apply ##sys#append (map (lambda (x) (car x)) vbindings))]
     384             [aliases (map (lambda (v) (cons v (r (gensym v)))) vars)]
     385             [lookup (lambda (v) (cdr (assq v aliases)))] )
     386        `(,%let ,(map (lambda (v) (##sys#list v '(##core#undefined))) vars)
     387                ,@(map (lambda (vb)
     388                         `(##sys#call-with-values
     389                           (,%lambda () ,(cadr vb))
     390                           (,%lambda ,(map lookup (car vb))
     391                                     ,@(map (lambda (v) `(##core#set! ,v ,(lookup v))) (car vb)) ) ) )
     392                       vbindings)
     393                ,@body) ) ) ) ) )
     394
     395(##sys#extend-macro-environment
     396 'nth-value '()
     397 (##sys#er-transformer
     398  (lambda (form r c)
     399    (##sys#check-syntax 'nth-value form '(_ _ _))
     400    (let ((v (r 'tmp))
     401          (%list-ref (r 'list-ref))
     402          (%lambda (r 'lambda)))
     403      `(##sys#call-with-values
     404        (,%lambda () ,exp)
     405        (,%lambda ,v (,%list-ref ,v ,i)) ) ) ) ) )
     406
     407(##sys#extend-macro-environment
     408 'define-inline '()
     409 (##sys#er-transformer
     410  (lambda (form r c)
     411    (let ((%lambda (r 'lambda)))
     412      (letrec ([quotify-proc
     413                (lambda (xs id)
     414                  (##sys#check-syntax id xs '#(_ 1))
     415                  (let* ([head (car xs)]
     416                         [name (if (pair? head) (car head) head)]
     417                         [val (if (pair? head)
     418                                  `(,%lambda ,(cdr head) ,@(cdr xs))
     419                                  (cadr xs) ) ] )
     420                    (when (or (not (pair? val)) (not (c %lambda (car val))))
     421                      (syntax-error
     422                       'define-inline "invalid substitution form - must be lambda"
     423                       name) )
     424                    (list (list (r 'quote) name) val) ) ) ] )
     425        `(##core#define-inline ,@(quotify-proc args 'define-inline)))) ) ) )
     426
     427(##sys#extend-macro-environment
     428 'define-constant '()
     429 (##sys#er-transformer
     430  (lambda (form r c)
     431    (##sys#check-syntax 'define-constant form '(_ variable _))
     432    `(##core#define-constant (,(r 'quote) ,(cadr form)) ,(caddr form)))))
     433
     434(##sys#extend-macro-environment
     435 'and-let* '()
     436 (##sys#er-transformer
     437  (lambda (form r c)
     438    (##sys#check-syntax 'and-let* form '(_ #((_ _) 0) . _))
     439    (let ((bindings (cadr form))
     440          (body (cddr form))
     441          (%if (r 'if)))
     442      (let fold ([bs bindings])
     443        (if (null? bs)
     444            `(,(r 'begin) ,@body)
     445            (let ([b (##sys#slot bs 0)]
     446                  [bs2 (##sys#slot bs 1)] )
     447              (cond [(not-pair? b) `(,%if ,b ,(fold bs2) #f)]
     448                    [(null? (##sys#slot b 1)) `(,%if ,(##sys#slot b 0) ,(fold bs2) #f)]
     449                    [else
     450                     (let ([var (##sys#slot b 0)])
     451                       `(,(r 'let) ((,var ,(cadr b)))
     452                         (,%if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) ) ) ) )
     453
     454(##sys#extend-macro-environment
     455 'select '()
     456 (##sys#er-transformer
     457  (lambda (form r c)
     458    (##sys#check-syntax 'select form '(_ _ . _))
     459    (let ((exp (cadr form))
     460          (body (cddr form))
     461          (tmp (r 'tmp))
     462          (%if (r 'if))
     463          (%else (r 'else))
     464          (%or (r 'or))
     465          (%eqv? (r 'eqv?))
     466          (%begin (r 'begin)))
     467      `(,(r 'let) ((,tmp ,exp))
     468        ,(let expand ((clauses body))
     469           (if (not (pair? clauses))
     470               '(##core#undefined)
     471               (let ((clause (##sys#slot clauses 0))
     472                     (rclauses (##sys#slot clauses 1)) )
     473                 (##sys#check-syntax 'select clause '#(_ 1))
     474                 (if (c %else (car clause))
     475                     `(,%begin ,@(cdr clause))
     476                     `(,%if (,%or ,@(map (lambda (x) `(,%eqv? ,tmp ,x))
     477                                         (car clause) ) )
     478                            (,%begin ,@(cdr clause))
     479                            ,(expand rclauses) ) ) ) ) ) ) ) ) ) )
    431480
    432481
     
    507556;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
    508557
    509 (define-macro (let-optionals arg-list var/defs . body)
    510 
    511   ;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
    512   ;; I wish I had a reasonable loop macro.
    513 
    514   (define (make-default-procs vars body-proc defaulter-names defs rename)
    515     (let recur ((vars (reverse vars))
    516                 (defaulter-names (reverse defaulter-names))
    517                 (defs (reverse defs))
    518                 (next-guy body-proc))
    519       (if (null? vars) '()
    520           (let ((vars (cdr vars)))
    521             `((,(car defaulter-names)
    522                (lambda ,(reverse vars)
    523                  (,next-guy ,@(reverse vars) ,(car defs))))
    524               . ,(recur vars
    525                         (cdr defaulter-names)
    526                         (cdr defs)
    527                         (car defaulter-names)))))))
    528 
    529 
    530     ;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
    531 
    532   (define (make-if-tree vars defaulters body-proc rest rename)
    533     (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
    534       (if (null? vars)
    535           `(if (##core#check (null? ,rest))
    536                (,body-proc . ,(reverse non-defaults))
    537                (##sys#error (##core#immutable '"too many optional arguments") ,rest))
    538           (let ((v (car vars)))
    539             `(if (null? ,rest)
    540                  (,(car defaulters) . ,(reverse non-defaults))
    541                  (let ((,v (car ,rest))
    542                        (,rest (cdr ,rest)))
    543                    ,(recur (cdr vars)
    544                            (cdr defaulters)
    545                            (cons v non-defaults))))))))
    546 
    547   (##sys#check-syntax 'let-optionals var/defs '#((symbol _) 0))
    548   (##sys#check-syntax 'let-optionals body '#(_ 1))
    549   (let* ((vars (map car var/defs))
    550          (prefix-sym (lambda (prefix sym)
    551                        (string->symbol (string-append prefix (symbol->string sym)))))
    552 
    553          ;; Private vars, one for each user var.
    554          ;; We prefix the % to help keep macro-expanded code from being
    555          ;; too confusing.
    556          (vars2 (map (lambda (v) (gensym (prefix-sym "%" v)))
    557                      vars))
    558 
    559          (defs (map cadr var/defs))
    560          (body-proc (gensym 'body))
    561 
    562          ;; A private var, bound to the value of the ARG-LIST expression.
    563          (rest-var (gensym '%rest))
    564 
    565          (defaulter-names (map (lambda (var) (gensym (prefix-sym "def-" var)))
    566                                vars))
    567 
    568          (defaulters (make-default-procs vars2 body-proc
    569                                          defaulter-names defs gensym))
    570          (if-tree (make-if-tree vars2 defaulter-names body-proc
    571                                 rest-var gensym)))
    572 
    573     `(let* ((,rest-var ,arg-list)
    574             (,body-proc (lambda ,vars . ,body))
    575             . ,defaulters)
    576        ,if-tree) ) )
     558(##sys#extend-macro-environment
     559 'let-optionals '()
     560 (##sys#er-transformer
     561  (lambda (form r c)
     562    (##sys#check-syntax 'let-optionals form '(_ _ . _))
     563    (let ((arg-list (cadr form))
     564          (var/defs (caddr form))
     565          (body (cdddr form))
     566          (%null? (r 'null?))
     567          (%if (r 'if))
     568          (%let (r 'let))
     569          (%car (r 'car))
     570          (%cdr (r 'cdr))
     571          (%lambda (r 'lambda)))
     572
     573      ;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
     574      ;; I wish I had a reasonable loop macro.
     575
     576      (define (make-default-procs vars body-proc defaulter-names defs rename)
     577        (let recur ((vars (reverse vars))
     578                    (defaulter-names (reverse defaulter-names))
     579                    (defs (reverse defs))
     580                    (next-guy body-proc))
     581          (if (null? vars) '()
     582              (let ((vars (cdr vars)))
     583                `((,(car defaulter-names)
     584                   (,%lambda ,(reverse vars)
     585                             (,next-guy ,@(reverse vars) ,(car defs))))
     586                  . ,(recur vars
     587                            (cdr defaulter-names)
     588                            (cdr defs)
     589                            (car defaulter-names)))))))
     590
     591
     592      ;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
     593
     594      (define (make-if-tree vars defaulters body-proc rest rename)
     595        (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
     596          (if (null? vars)
     597              `(,%if (##core#check (,%null? ,rest))
     598                     (,body-proc . ,(reverse non-defaults))
     599                     (##sys#error (##core#immutable '"too many optional arguments") ,rest))
     600              (let ((v (car vars)))
     601                `(,%if (null? ,rest)
     602                       (,(car defaulters) . ,(reverse non-defaults))
     603                       (,%let ((,v (,%car ,rest))
     604                               (,rest (,%cdr ,rest)))
     605                              ,(recur (cdr vars)
     606                                      (cdr defaulters)
     607                                      (cons v non-defaults))))))))
     608
     609      (##sys#check-syntax 'let-optionals var/defs '#((variable _) 0))
     610      (##sys#check-syntax 'let-optionals body '#(_ 1))
     611      (let* ((vars (map car var/defs))
     612             (prefix-sym (lambda (prefix sym)
     613                           (string->symbol (string-append prefix (symbol->string sym)))))
     614
     615             ;; Private vars, one for each user var.
     616             ;; We prefix the % to help keep macro-expanded code from being
     617             ;; too confusing.
     618             (vars2 (map (lambda (v) (r (prefix-sym "%" v)))
     619                         vars))
     620
     621             (defs (map cadr var/defs))
     622             (body-proc (r 'body))
     623
     624             ;; A private var, bound to the value of the ARG-LIST expression.
     625             (rest-var (r '%rest))
     626
     627             (defaulter-names (map (lambda (var) (r (prefix-sym "def-" var)))
     628                                   vars))
     629
     630             (defaulters (make-default-procs vars2 body-proc
     631                                             defaulter-names defs gensym))
     632             (if-tree (make-if-tree vars2 defaulter-names body-proc
     633                                    rest-var gensym)))
     634
     635        `(,(r 'let*) ((,rest-var ,arg-list)
     636                      (,body-proc (,%lambda ,vars . ,body))
     637                      . ,defaulters)
     638          ,if-tree) ) ))))
     639
     640
     641;;;*** make hygienic
    577642
    578643
  • chicken/branches/beyond-hope/compiler.scm

    r10345 r10359  
    480480        x) )
    481481
    482   (define (resolve-atom x se dest)
     482  (define (resolve-variable x se dest)
    483483    (cond [(and constants-used (##sys#hash-table-ref constant-table x))
    484484           => (lambda (val) (walk (car val) se dest)) ]
     
    505505             (if (symbol? x2)
    506506                 x2
    507                  x))]))
     507                 (##sys#rename-global x se)))]))
    508508
    509509  (define (walk x se dest)
    510510    (cond ((symbol? x)
    511            (##sys#alias-global-hook (resolve-atom x se dest)))
     511           (resolve-variable x se dest))
    512512          ((not-pair? x)
    513513           (if (constant? x)
     
    544544                                (walk (cadddr x) se #f) ) ) )
    545545
    546                         ((quote)
    547                          (##sys#check-syntax 'quote x '(quote _) #f se)
     546                        ((quote ##core#syntax)
     547                         (##sys#check-syntax 'quote x '(_ _) #f se)
    548548                         `(quote ,(##sys#strip-syntax (cadr x))))
    549 
    550                         ((##core#syntax)
    551                          `(quote ,(cadr x)))
    552549
    553550                        ((##core#check)
     
    718715                                [val (walk (caddr x) se var0)] )
    719716                           (when (eq? var var0) ; global?
    720                              (set! var (##sys#alias-global-hook var))
     717                             (set! var (##sys#rename-global var se))
    721718                             (when safe-globals-flag
    722719                               (set! always-bound-to-procedure
  • chicken/branches/beyond-hope/eval.scm

    r10211 r10359  
    240240(define ##sys#unbound-in-eval #f)
    241241(define ##sys#eval-debug-level 1)
    242 (define (##sys#alias-global-hook s) s)
    243242
    244243(define ##sys#compile-to-closure
     
    291290               (receive (i j) (lookup x e se)
    292291                 (cond [(not i)
    293                         (let ((x (##sys#alias-global-hook j)))
     292                        (let ((x (##sys#rename-global j se)))
    294293                          (if ##sys#eval-environment
    295                               (let ([loc (##sys#hash-table-location ##sys#eval-environment j #t)])
     294                              (let ([loc (##sys#hash-table-location ##sys#eval-environment x #t)])
    296295                                (unless loc (##sys#syntax-error-hook "reference to undefined identifier" j))
    297296                                (cond-expand
     
    304303                                          val) ) ) ] ) )
    305304                              (cond-expand
    306                                [unsafe (lambda v (##core#inline "C_slot" j 0))]
     305                               [unsafe (lambda v (##core#inline "C_slot" x 0))]
    307306                               [else
    308                                 (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? j)))
    309                                   (set! ##sys#unbound-in-eval (cons (cons j cntr) ##sys#unbound-in-eval)) )
    310                                 (lambda v (##core#inline "C_retrieve" j))] ) ) ) ]
     307                                (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? x)))
     308                                  (set! ##sys#unbound-in-eval (cons (cons x cntr) ##sys#unbound-in-eval)) )
     309                                (lambda v (##core#inline "C_retrieve" x))] ) ) ) ]
    311310                       [(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
    312311                       [else (lambda (v) (##sys#slot (##core#inline "C_u_i_list_ref" v i) j))] ) ) ]
     
    399398                              (let ((val (compile (caddr x) e var tf cntr se)))
    400399                                (cond [(not i)
    401                                        (let ([var (##sys#alias-global-hook var)])
     400                                       (let ([var (##sys#rename-global var se)])
    402401                                         (if ##sys#eval-environment
    403402                                             (let ([loc (##sys#hash-table-location
     
    663662                         [(##core#app)
    664663                          (compile-call (cdr x) e tf cntr se) ]
     664
     665                         ((##core#environment)
     666                          (let* ((name (cadr x))
     667                                (imports (caddr x))
     668                                (exports (cadddr x))
     669                                (exprename
     670                                 ((##sys#compile-to-closure
     671                                   (car (cddddr x))
     672                                   '()
     673                                   (##sys#current-meta-environment))
     674                                  '()))
     675                                (body (cdr (cddddr x)))
     676                                (module
     677                                    (##sys#register-module
     678                                     name
     679                                     (##sys#make-module
     680                                      name
     681                                      exports
     682                                      exprename
     683                                      (map (lambda (imp)
     684                                             (cons
     685                                              (car imp)
     686                                              ((##sys#compile-to-closure
     687                                                (cadr imp)
     688                                                '()
     689                                                (##sys#current-meta-environment))
     690                                               '())))
     691                                           imports) ) ) ) )
     692                            (parameterize ((##sys#current-module module)
     693                                           (##sys#current-environment (cddr module)))
     694                              (pp (##sys#current-module))
     695                              (let ((forms
     696                                     (map (lambda (x)
     697                                            (compile x e #f tf cntr (##sys#current-environment)) )
     698                                          body) ) )
     699                                (lambda (v)
     700                                  (for-each
     701                                   (lambda (x) (##core#app x v))
     702                                   forms))))))
    665703
    666704                         [else
  • chicken/branches/beyond-hope/expand.scm

    r10352 r10359  
    7979          (else x))))
    8080
     81(define (##sys#alias-global-hook s) s)
     82
     83(define (##sys#rename-global id se)
     84  (cond ((##sys#qualified-symbol? id) id)
     85        ((##sys#current-module) =>
     86         (lambda (m)
     87           (let ((id2 (##sys#string->symbol
     88                       (string-append
     89                        (##sys#slot (car m) 1)
     90                        "$$"
     91                        (##sys#slot id 1)))))
     92             id2) ) )
     93        (else (##sys#alias-global-hook id) ) ) )
     94
    8195
    8296;;; Macro handling
     
    8599
    86100(define (##sys#extend-macro-environment name se handler)
    87   (cond ((lookup name ##sys#macro-environment) =>
     101  (cond ((##sys#current-module) =>
     102         (lambda (m)
     103           ;; fixup exports
     104           (cond ((assq name (cadr m))  => (cut set-cdr! <> (list se handler))))
     105           (##sys#current-environment
     106            (cons (list name se handler) (##sys#current-environment)))))
     107        ((lookup name ##sys#macro-environment) =>
    88108         (lambda (a)
    89109           (set-car! a se)
     
    244264      (define (->keyword s) (string->keyword (##sys#slot s 1)))
    245265      (let ([rvar #f]
    246             [hasrest #f] )
     266            [hasrest #f]
     267            (%let* (macro-alias 'let* se))
     268            (%lambda (macro-alias 'lambda se))
     269            (%opt (macro-alias 'optional se))
     270            (%let-optionals (macro-alias 'let-optionals se))
     271            (%let-optionals* (macro-alias 'let-optionals* se))
     272            (%let (macro-alias 'let se)))
    247273        (let loop ([mode 0]             ; req, opt, rest, key, end
    248274                   [req '()]
     
    256282                         (if (null? key)
    257283                             body
    258                              `((,(macro-alias 'let* se)
     284                             `((,%let*
    259285                                ,(map (lambda (k)
    260286                                        (let ([s (car k)])
     
    262288                                                ',(->keyword s) ,rvar
    263289                                                ,@(if (pair? (cdr k))
    264                                                       `((,(macro-alias 'lambda se)
    265                                                          () ,@(cdr k)))
    266                                                       '() ) ) ] ) )
     290                                                      `(,%lambda () ,@(cdr k)))
     291                                                '() ) ] ) )
    267292                                      (reverse key) )
    268293                                ,@body) ) ) ] )
    269294                    (cond [(null? opt) body]
    270295                          [(and (not hasrest) (null? key) (null? (cdr opt)))
    271                            `((,(macro-alias 'let se)
    272                               ([,(caar opt) (,(macro-alias 'optional se)
    273                                              ,rvar ,(cadar opt))])
    274                                ,@body) ) ]
     296                           `((,%let
     297                              ([,(caar opt) (,%opt ,rvar ,(cadar opt))])
     298                              ,@body) ) ]
    275299                          [(and (not hasrest) (null? key))
    276                            `((,(macro-alias 'let-optionals se)
     300                           `((,%let-optionals
    277301                              ,rvar ,(reverse opt) ,@body))]
    278302                          [else
    279                            `((,(macro-alias 'let-optionals* se)
     303                           `((,%let-optionals*
    280304                              ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar)))
    281305                              ,@body))] ) ) ) ]
     
    290314                 (err "invalid lambda list syntax") ]
    291315                [else
    292                  (let ([x (or (lookup (car llist) se) (car llist))]
    293                        [r (##sys#slot llist 1)])
     316                 (let* ((var (car llist))
     317                        (x (or (and (symbol? var) (lookup var se)) var))
     318                        (r (##sys#slot llist 1)))
    294319                   (case x
    295320                     [(#!optional)
    296                       (if (not rvar) (set! rvar (gensym)))
     321                      (if (not rvar) (set! rvar (macro-alias 'tmp se)))
    297322                      (if (eq? mode 0)
    298323                          (loop 1 req '() '() r)
     
    308333                          (err "`#!rest' argument marker in wrong context") ) ]
    309334                     [(#!key)
    310                       (if (not rvar) (set! rvar (gensym)))
     335                      (if (not rvar) (set! rvar (macro-alias 'tmp se)))
    311336                      (if (fx<= mode 3)
    312337                          (loop 3 req opt '() r)
     
    602627
    603628
     629;;; lowlevel module support
     630
     631(define ##sys#current-module (make-parameter #f))
     632(define ##sys#module-table '())
     633
     634(define (##sys#register-module name module)
     635  (cond ((assq name ##sys#module-table) =>
     636         (lambda (entry)
     637           (set-cdr! entry (cdr module))
     638           entry))
     639        (else
     640         (set! ##sys#module-table (cons module ##sys#module-table))
     641         module) ) )
     642
     643(define (##sys#make-module name exports exprename imports)
     644  (let ((prefix (##sys#string-append (##sys#slot name 1) "$$")))
     645    (let loop ((se '()) (imports imports))
     646      (cond ((null? imports)
     647             (let ((exps
     648                     (map (lambda (ex)
     649                            (cons (exprename ex)
     650                                  (cond ((assq ex se) => cdr) ; already imported?
     651                                        (else
     652                                         (##sys#string->symbol
     653                                          (##sys#string-append prefix (##sys#slot ex 1)))))))
     654                          exports) ) )
     655               (cons name (cons exps se))))
     656            ((assq (caar imports) ##sys#module-table) =>
     657             (lambda (m)
     658               (let ((imprename (cdar imports)))
     659                 (loop (let filter ((exps (cadr m)))
     660                         (cond ((null? exps) se)
     661                               ((imprename (caar exps)) =>
     662                                (lambda (r)
     663                                  (cons
     664                                   (cons r (cdar exps) )
     665                                   (filter (cdr exps)))))
     666                               (else (filter (cdr exps)))))
     667                       (cdr imports)))))
     668            (else
     669             (syntax-error "importing unknown module" (car imports) name))))))
     670
     671
    604672;;; Macro definitions:
    605673
  • chicken/branches/beyond-hope/library.scm

    r10211 r10359  
    11621162             [i (split str len)] )
    11631163        (and i (##sys#substring str 0 i)) ) ) ) )
     1164
     1165(define (##sys#qualified-symbol? s)
     1166  (let ((str (##sys#slot s 1)))
     1167    (and (fx> (##sys#size str) 0)
     1168         (fx<= (##sys#byte str 0) namespace-max-id-len))))
    11641169
    11651170(define ##sys#string->qualified-symbol
Note: See TracChangeset for help on using the changeset viewer.