Changeset 10370 in project


Ignore:
Timestamp:
04/07/08 09:23:33 (12 years ago)
Author:
felix winkelmann
Message:

updated synrules from upstream (riaxpander egg); some conversions; some fixes; added tests

Location:
chicken/branches/beyond-hope
Files:
7 edited
1 moved

Legend:

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

    r10359 r10370  
    1111* test macros expanding into syntax-rules
    1212* test local define{-values,-syntax,} expansion
    13 * test pattern matching macros and interaction with hygienic macros
    1413* test extended lambda-lists
    1514* test examples from r5rs spec
  • chicken/branches/beyond-hope/chicken-more-macros.scm

    r10359 r10370  
    639639
    640640
    641 ;;;*** make hygienic
    642 
    643 
    644641;;; (:optional rest-arg default-exp)
    645642;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    654651;;; - If REST-ARG has >1 element, error.
    655652
    656 (define-macro (optional rest default-exp)
    657   (let ([var (gensym)])
    658     `(let ((,var ,rest))
    659        (if (null? ,var)
    660            ,default-exp
    661            (if (##core#check (null? (cdr ,var)))
    662                (car ,var)
    663                (##sys#error (##core#immutable '"too many optional arguments") ,var))))))
    664 
    665 (define-macro (:optional . args)        ; DEPRECATED to avoid conflicts with keyword-style prefix
    666   `(optional ,@args) )
     653(##sys#extend-macro-environment
     654 'optional '()
     655 (##sys#er-transformer
     656  (lambda (form r c)
     657    (##sys#check-syntax 'optional form '(_ _ . #(_ 0 1)))
     658    (let ((var (r 'tmp))
     659          (%null? (r 'null?))
     660          (%if (r 'if)))
     661      `(,(r 'let) ((,var ,(cadr form)))
     662        (,%if (,%null? ,var)
     663              ,(optional (cddr form) #f)
     664              (,%if (##core#check (,%null? (,(r 'cdr) ,var)))
     665                    (,(r 'car) ,var)
     666                    (##sys#error
     667                     (##core#immutable '"too many optional arguments")
     668                     ,var))))))))
    667669
    668670
     
    682684;;;   values in the ARGS list.
    683685
    684 (define-macro (let-optionals* args var/defs . body)
    685   (##sys#check-syntax 'let-optionals* var/defs '#(_ 0))
    686   (##sys#check-syntax 'let-optionals* body '#(_ 1))
    687   (let ([rvar (gensym)])
    688     `(let ((,rvar ,args))
    689        ,(let loop ([args rvar] [vardefs var/defs])
    690           (if (null? vardefs)
    691               `(if (##core#check (null? ,args))
    692                    (let () ,@body)
    693                    (##sys#error (##core#immutable '"too many optional arguments") ,args) )
    694               (let ([head (car vardefs)])
    695                 (if (pair? head)
    696                     (let ([rvar2 (gensym)])
    697                       `(let ((,(car head) (if (null? ,args) ,(cadr head) (car ,args)))
    698                              (,rvar2 (if (null? ,args) '() (cdr ,args))) )
    699                          ,(loop rvar2 (cdr vardefs)) ) )
    700                     `(let ((,head ,args)) ,@body) ) ) ) ) ) ) )
     686(##sys#extend-macro-environment
     687 'let-optional' '()
     688 (##sys#er-transformer
     689  (lambda (form r c)
     690    (##sys#check-syntax 'let-optionals* form '(_ _ list . _))
     691    (let ((args (cadr form))
     692          (var/defs (caddr form))
     693          (body (cdddr form))
     694          (%let (r 'let))
     695          (%if (r 'if))
     696          (%null? (r 'null?))
     697          (%car (r 'car))
     698          (%cdr (r 'cdr)))
     699      (let ((rvar (r 'tmp)))
     700        `(,%let ((,rvar ,args))
     701                ,(let loop ([args rvar] [vardefs var/defs])
     702                   (if (null? vardefs)
     703                       `(,%if (##core#check (,%null? ,args))
     704                              (,%let () ,@body)
     705                              (##sys#error
     706                               (##core#immutable '"too many optional arguments")
     707                               ,args) )
     708                       (let ([head (car vardefs)])
     709                         (if (pair? head)
     710                             (let ((rvar2 (r 'tmp2)))
     711                               `(,%let ((,(car head) (,%if (,%null? ,args)
     712                                                           ,(cadr head)
     713                                                           (,%car ,args)))
     714                                        (,rvar2 (,%if (,%null? ,args)
     715                                                      '()
     716                                                      (,%cdr ,args))) )
     717                                       ,(loop rvar2 (cdr vardefs)) ) )
     718                             `(,%let ((,head ,args)) ,@body) ) ) ) ) ) ) ))))
    701719
    702720
    703721;;; case-lambda (SRFI-16):
    704722
    705 (define-macro (case-lambda . clauses)
    706   (define (genvars n)
    707     (let loop ([i 0])
    708       (if (fx>= i n)
    709           '()
    710           (cons (gensym) (loop (fx+ i 1))) ) ) )
    711   (##sys#check-syntax 'case-lambda clauses '#(_ 0))
    712   (require 'srfi-1)                     ; Urgh...
    713   (let* ((mincount (apply min (map (lambda (c)
    714                                      (##sys#decompose-lambda-list
    715                                       (car c)
    716                                       (lambda (vars argc rest) argc) ) )
    717                                    clauses) ) )
    718          (minvars (genvars mincount))
    719          (rvar (gensym))
    720          (lvar (gensym)) )
    721     `(lambda ,(append minvars rvar)
    722        (let ((,lvar (length ,rvar)))
    723          ,(fold-right
    724            (lambda (c body)
    725              (##sys#decompose-lambda-list
    726               (car c)
    727               (lambda (vars argc rest)
    728                 (##sys#check-syntax 'case-lambda (car c) 'lambda-list)
    729                 `(if ,(let ([a2 (fx- argc mincount)])
    730                         (if rest
    731                             (if (zero? a2)
    732                                 #t
    733                                 `(fx>= ,lvar ,a2) )
    734                             `(fx= ,lvar ,a2) ) )
    735                      ,(receive
    736                        (vars1 vars2) (split-at! (take vars argc) mincount)
    737                        (let ((bindings
    738                               (let build ((vars2 vars2) (vrest rvar))
    739                                 (if (null? vars2)
    740                                     (cond (rest `(let ((,rest ,vrest)) ,@(cdr c)))
    741                                           ((null? (cddr c)) (cadr c))
    742                                           (else `(let () ,@(cdr c))) )
    743                                     (let ((vrest2 (gensym)))
    744                                       `(let ((,(car vars2) (car ,vrest))
    745                                              (,vrest2 (cdr ,vrest)) )
    746                                          ,(if (pair? (cdr vars2))
    747                                               (build (cdr vars2) vrest2)
    748                                               (build '() vrest2) ) ) ) ) ) ) )
    749                          (if (null? vars1)
    750                              bindings
    751                              `(let ,(map list vars1 minvars) ,bindings) ) ) )
    752                      ,body) ) ) )
    753            '(##core#check (##sys#error (##core#immutable '"no matching clause in call to 'case-lambda' form")))
    754            clauses) ) ) ) )
     723(##sys#extend-macro-environment
     724 'case-lambda '()
     725 (##sys#er-transformer
     726  (lambda (form r c)
     727    (##sys#check-syntax 'case-lambda form '(_ . _))
     728    (define (genvars n)
     729      (let loop ([i 0])
     730        (if (fx>= i n)
     731            '()
     732            (cons (r (gensym)) (loop (fx+ i 1))) ) ) )
     733    (require 'srfi-1)                   ; Urgh...
     734    (let* ((mincount (apply min (map (lambda (c)
     735                                       (##sys#decompose-lambda-list
     736                                        (car c)
     737                                        (lambda (vars argc rest) argc) ) )
     738                                     clauses) ) )
     739           (minvars (genvars mincount))
     740           (rvar (r 'rvar))
     741           (lvar (r 'lvar))
     742           (%lambda (r 'lambda))
     743           (%let (r 'let))
     744           (%if (r 'if)))
     745      `(,%lambda ,(append minvars rvar)
     746                 (,%let ((,lvar (length ,rvar)))
     747                        ,(fold-right
     748                          (lambda (c body)
     749                            (##sys#decompose-lambda-list
     750                             (car c)
     751                             (lambda (vars argc rest)
     752                               (##sys#check-syntax 'case-lambda (car c) 'lambda-list)
     753                               `(,%if ,(let ([a2 (fx- argc mincount)])
     754                                         (if rest
     755                                             (if (zero? a2)
     756                                                 #t
     757                                                 `(,(r 'fx>=) ,lvar ,a2) )
     758                                             `(,(r 'fx=) ,lvar ,a2) ) )
     759                                      ,(receive (vars1 vars2)
     760                                           (split-at! (take vars argc) mincount)
     761                                         (let ((bindings
     762                                                (let build ((vars2 vars2) (vrest rvar))
     763                                                  (if (null? vars2)
     764                                                      (cond (rest `(,%let ((,rest ,vrest)) ,@(cdr c)))
     765                                                            ((null? (cddr c)) (cadr c))
     766                                                            (else `(,%let () ,@(cdr c))) )
     767                                                      (let ((vrest2 (r (gensym))))
     768                                                        `(,%let ((,(car vars2) (,(r 'car) ,vrest))
     769                                                                 (,vrest2 (,(r 'cdr) ,vrest)) )
     770                                                                ,(if (pair? (cdr vars2))
     771                                                                     (build (cdr vars2) vrest2)
     772                                                                     (build '() vrest2) ) ) ) ) ) ) )
     773                                           (if (null? vars1)
     774                                               bindings
     775                                               `(,%let ,(map list vars1 minvars) ,bindings) ) ) )
     776                                      ,body) ) ) )
     777                          '(##core#check (##sys#error (##core#immutable '"no matching clause in call to 'case-lambda' form")))
     778                          (cdr form))))))))
    755779
    756780
    757781;;; Record printing:
    758782
    759 (define-macro (define-record-printer head . body)
    760   (cond [(pair? head)
    761          (##sys#check-syntax 'define-record-printer (cons head body) '((symbol symbol symbol) . #(_ 1)))
    762          `(##sys#register-record-printer ',(##sys#slot head 0) (lambda ,(##sys#slot head 1) ,@body)) ]
    763         [else
    764          (##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
    765          `(##sys#register-record-printer ',head ,@body) ] ) )
     783(##sys#extend-macro-environment
     784 'define-record-printer '()
     785 (##sys#er-transformer
     786  (lambda (form r c)
     787    (##sys#check-syntax 'define-record-printer form '(_ . _))
     788    (cond [(pair? head)
     789           (##sys#check-syntax
     790            'define-record-printer (cons head body)
     791            '((symbol symbol symbol) . #(_ 1)))
     792           `(##sys#register-record-printer
     793             ',(##sys#slot head 0)
     794             (,(r 'lambda) ,(##sys#slot head 1) ,@body)) ]
     795          [else
     796           (##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
     797           `(##sys#register-record-printer ',head ,@body) ] ) )))
    766798
    767799
    768800;;; Exceptions:
    769801
    770 (define-macro (handle-exceptions var handler . body)
    771   (let ([k (gensym)]
    772         [args (gensym)] )
    773     `((call-with-current-continuation
    774        (lambda (,k)
    775          (with-exception-handler
    776           (lambda (,var) (,k (lambda () ,handler)))
    777           (lambda ()
     802(##sys#extend-macro-environment
     803 'handle-exceptions '()
     804 (##sys#er-transformer
     805  (lambda (form r c)
     806    (##sys#check-syntax 'handle-exceptions form '(_ variable _ . _))
     807  (let ((k (r 'k))
     808        (args (r 'args))
     809        (%lambda (r 'lambda)))
     810    `((,(r 'call-with-current-continuation)
     811       (,%lambda (,k)
     812         (,(r 'with-exception-handler)
     813          (,%lambda (,(cadr form)) (,k (,%lambda () ,(caddr form))))
     814          (,%lambda ()
    778815            (##sys#call-with-values
    779              (lambda () ,@body)
    780              (lambda ,args (,k (lambda () (##sys#apply ##sys#values ,args)))) ) ) ) ) ) ) ) )
    781 
    782 (define-macro (condition-case exp . clauses)
    783   (let ([exvar (gensym)]
    784         [kvar (gensym)] )
    785     (define (parse-clause c)
    786       (let* ([var (and (symbol? (car c)) (car c))]
    787              [kinds (if var (cadr c) (car c))]
    788              [body (if var (cddr c) (cdr c))] )
    789         (if (null? kinds)
    790             `(else
    791               ,(if var
    792                    `(let ([,var ,exvar]) ,@body)
    793                    `(let () ,@body) ) )
    794             `((and ,kvar ,@(map (lambda (k) `(memv ',k ,kvar)) kinds))
    795               ,(if var
    796                    `(let ([,var ,exvar]) ,@body)
    797                    `(let () ,@body) ) ) ) ) )
    798     `(handle-exceptions ,exvar
    799          (let ([,kvar (and (##sys#structure? ,exvar 'condition) (##sys#slot ,exvar 1))])
    800            (cond ,@(map parse-clause clauses)
    801                  (else (##sys#signal ,exvar)) ) )
    802        ,exp) ) )
     816             (,%lambda () ,@(cdddr form))
     817             (,%lambda
     818              ,args
     819              (,k (lambda () (##sys#apply ##sys#values ,args)))) ) ) ) ) ) ) ) ) ) )
     820
     821(##sys#extend-macro-environment
     822 'condition-case '()
     823 (##sys#er-transformer
     824  (lambda (form r c)
     825    (##sys#check-syntax 'condition-case form '(_ _ . _))
     826    (let ((exvar (r 'exvar))
     827          (kvar (r 'kvar))
     828          (%and (r 'and))
     829          (%let (r 'let))
     830          (%memv (r 'memv))
     831          (%else (r 'else)))
     832      (define (parse-clause c)
     833        (let* ([var (and (symbol? (car c)) (car c))]
     834               [kinds (if var (cadr c) (car c))]
     835               [body (if var (cddr c) (cdr c))] )
     836          (if (null? kinds)
     837              `(,%else
     838                ,(if var
     839                     `(,%let ([,var ,exvar]) ,@body)
     840                     `(,%let () ,@body) ) )
     841              `((,%and ,kvar ,@(map (lambda (k) `(,%memv ',k ,kvar)) kinds))
     842                ,(if var
     843                     `(,%let ([,var ,exvar]) ,@body)
     844                     `(,%let () ,@body) ) ) ) ) )
     845      `(,(r 'handle-exceptions) ,exvar
     846        (,%let ([,kvar (,%and (##sys#structure? ,exvar 'condition)
     847                              (##sys#slot ,exvar 1))])
     848               (,(r 'cond) ,@(map parse-clause (cddr form))
     849                (,%else (##sys#signal ,exvar)) ) )
     850        ,(cadr form))))))
    803851
    804852
    805853;;; SRFI-9:
    806854
    807 (define-macro (define-record-type t conser pred . slots)
    808   (let ([vars (cdr conser)]
    809         [slotnames (map car slots)] )
    810     `(begin
    811        (define ,conser
    812          (##sys#make-structure
    813           ',t
    814           ,@(map (lambda (sname)
    815                    (if (memq sname vars)
    816                        sname
    817                        '(##sys#void) ) )
    818                  slotnames) ) )
    819        (define (,pred x) (##sys#structure? x ',t))
    820        ,@(let loop ([slots slots] [i 1])
    821            (if (null? slots)
    822                '()
    823                (let* ([slot (car slots)]
    824                       (setters (memq #:record-setters ##sys#features))
    825                       (setr? (pair? (cddr slot)))
    826                       (getr `(lambda (x)
    827                                (##core#check (##sys#check-structure x ',t))
    828                                (##sys#block-ref x ,i) ) ) )
    829                  `(,@(if setr?
    830                          `((define (,(caddr slot) x y)
    831                              (##core#check (##sys#check-structure x ',t))
    832                              (##sys#block-set! x ,i y)) )
    833                          '() )
    834                    (define ,(cadr slot)
    835                      ,(if (and setr? setters)
    836                           `(getter-with-setter ,getr ,(caddr slot))
    837                           getr) )
    838                    ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) )
     855(##sys#extend-macro-environment
     856 'define-recorcd-type '()
     857 (##sys#er-transformer
     858  (lambda (form r c)
     859    (##sys#check-syntax 'define-record-type form '(_ variable #(variable 1) variable . _))
     860    (let* ((t (cadr form))
     861          (conser (caddr form))
     862          (pred (cadddr form))
     863          (slots (cddddr form))
     864          (%begin (r 'begin))
     865          (%define (r 'define))
     866          (vars (cdr conser))
     867          (x (r 'x))
     868          (y (r 'y))
     869          (%getter-with-setter (r 'getter-with-setter))
     870          (slotnames (map car slots)))
     871      `(,%begin
     872        (,%define ,conser
     873                  (##sys#make-structure
     874                   ',t
     875                   ,@(map (lambda (sname)
     876                            (if (memq sname vars)
     877                                sname
     878                                '(##sys#void) ) )
     879                          slotnames) ) )
     880        (,%define (,pred ,x) (##sys#structure? ,x ',t))
     881        ,@(let loop ([slots slots] [i 1])
     882            (if (null? slots)
     883                '()
     884                (let* ([slot (car slots)]
     885                       (setters (memq #:record-setters ##sys#features))
     886                       (setr? (pair? (cddr slot)))
     887                       (getr `(,%lambda (,x)
     888                                        (##core#check (##sys#check-structure ,x ',t))
     889                                        (##sys#block-ref ,x ,i) ) ) )
     890                  `(,@(if setr?
     891                          `((,%define (,(caddr slot) ,x ,y)
     892                                      (##core#check (##sys#check-structure ,x ',t))
     893                                      (##sys#block-set! ,x ,i ,y)) )
     894                          '() )
     895                    (,%define ,(cadr slot)
     896                              ,(if (and setr? setters)
     897                                   `(,%getter-with-setter ,getr ,(caddr slot))
     898                                   getr) )
     899                    ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) ) )
     900
     901
     902;;;*** convert to er
    839903
    840904
  • chicken/branches/beyond-hope/distribution/manifest

    r10261 r10370  
    203203tests/port-tests.scm
    204204tests/test-gc-hook.scm
     205tests/matchable.scm
     206tests/match-tests.scm
     207tests/syntax-tests.scm
    205208tweaks.scm
    206209utils.scm
  • chicken/branches/beyond-hope/eval.scm

    r10359 r10370  
    889889               (fluid-let ([##sys#read-error-with-line-number #t]
    890890                           [##sys#current-source-filename fname]
    891                            (##sys#current-environment ##sys#current-environment)
    892                            (##sys#current-meta-environment ##sys#current-meta-environment)
    893891                           [##sys#current-load-path
    894892                            (and fname
  • chicken/branches/beyond-hope/expand.scm

    r10359 r10370  
    8282
    8383(define (##sys#rename-global id se)
    84   (cond ((##sys#qualified-symbol? id) id)
     84  (cond ((or (##sys#qualified-symbol? id)
     85             (let ((s (##sys#slot id 1)))
     86               (and (fx> (##sys#size s) 0)
     87                    (char=? #\ (string-ref s 0)))))
     88         id)
    8589        ((##sys#current-module) =>
    8690         (lambda (m)
  • chicken/branches/beyond-hope/synrules.scm

    r10216 r10370  
    6666  (define %car (r 'car))
    6767  (define %cdr (r 'cdr))
     68  (define %vector? (r 'vector?))
     69  (define %vector-length (r 'vector-length))
     70  (define %vector-ref (r 'vector-ref))
     71  (define %vector->list (r 'vector->list))
     72  (define %list->vector (r 'list->vector))
     73  (define %>= (r '>=))
     74  (define %= (r '=))
     75  (define %+ (r '+))
     76  (define %i (r 'i))
    6877  (define %compare (r 'compare))
    6978  (define %cond (r 'cond))
     
    128137                           ,@(process-match `(,%car ,%temp) (car pattern))
    129138                           ,@(process-match `(,%cdr ,%temp) (cdr pattern))))))
     139          ((vector? pattern)
     140           (process-vector-match input pattern))
    130141          ((or (null? pattern) (boolean? pattern) (char? pattern))
    131142           `((,%eq? ,input ',pattern)))
     
    142153                                (,%loop (,%cdr ,%l)))))))))
    143154
     155   (define (process-vector-match input pattern)
     156     (let* ((len (vector-length pattern))
     157            (segment? (and (>= len 2)
     158                           (eq? (vector-ref pattern (- len 1))
     159                                ellipsis))))
     160       `((,%let ((,%temp ,input))
     161          (,%and (,%vector? ,%temp)
     162                 ,(if segment?
     163                      `(,%>= (,%vector-length ,%temp) ,(- len 2))
     164                      `(,%= (,%vector-length ,%temp) ,len))
     165                 ,@(let lp ((i 0))
     166                     (cond
     167                      ((>= i len)
     168                       '())
     169                      ((and (= i (- len 2)) segment?)
     170                       `((,%let ,%loop ((,%i ,i))
     171                            (,%or (,%>= ,%i ,len)
     172                                  (,%and ,@(process-match
     173                                            `(,%vector-ref ,%temp ,%i)
     174                                            (vector-ref pattern (- len 2)))
     175                                         (,%loop (,%+ ,%i 1)))))))
     176                      (else
     177                       (append (process-match `(,%vector-ref ,%temp ,i)
     178                                              (vector-ref pattern i))
     179                               (lp (+ i 1)))))))))))
     180 
    144181  ;; Generate code to take apart the input expression
    145182  ;; This is pretty bad, but it seems to work (can't say why).
     
    161198           (append (process-pattern (car pattern) `(,%car ,path) mapit)
    162199                   (process-pattern (cdr pattern) `(,%cdr ,path) mapit)))
     200          ((vector? pattern)
     201           (let* ((len (vector-length pattern))
     202                  (segment? (and (>= len 2)
     203                                 (eq? (vector-ref pattern (- len 1))
     204                                      ellipsis))))
     205             (if segment?
     206                 (process-pattern (vector->list pattern)
     207                                  `(,%vector->list ,path)
     208                                  mapit)
     209                 (let lp ((i 0))
     210                   (cond
     211                    ((>= i len)
     212                     '())
     213                    (else
     214                     (append (process-pattern (vector-ref pattern i)
     215                                              `(,%vector-ref ,path ,i)
     216                                              mapit)
     217                             (lp (+ i 1)))))))))
    163218          (else '())))
    164219
     
    202257           `(,%cons ,(process-template (car template) dim env)
    203258                    ,(process-template (cdr template) dim env)))
     259          ((vector? template)
     260           `(,%list->vector
     261             ,(process-template (vector->list template) dim env)))
    204262          (else
    205263           `(,%quote ,template))))
     
    217275           (meta-variables (car pattern) dim
    218276                           (meta-variables (cdr pattern) dim vars)))
     277          ((vector? pattern)
     278           (meta-variables (vector->list pattern) dim vars))
    219279          (else vars)))
    220280
     
    238298                                (free-meta-variables (cdr template)
    239299                                                     dim env free)))
     300          ((vector? template)
     301           (free-meta-variables (vector->list template) dim env free))
    240302          (else free)))
    241303
  • chicken/branches/beyond-hope/tests/runtests.sh

    r8278 r10370  
    1414echo "======================================== library tests ..."
    1515../csi -w -s library-tests.scm
     16
     17echo "======================================== syntax tests ..."
     18../csi -w -s syntax-tests.scm
     19../csi -w matchable.scm -s match-tests.scm
    1620
    1721echo "======================================== hash-table tests ..."
  • chicken/branches/beyond-hope/tests/syntax-tests.scm

    r10369 r10370  
    186186           y)))
    187187)
     188
     189(define-syntax foo
     190  (syntax-rules ()
     191    ((_ #(a ...)) (list a ...))))
     192
     193(t '(1 2 3)
     194   (foo #(1 2 3))
     195)
Note: See TracChangeset for help on using the changeset viewer.