Changeset 7921 in project for chicken/trunk


Ignore:
Timestamp:
01/24/08 11:23:49 (13 years ago)
Author:
elf
Message:

reverted to 7870, ie just before i started mucking with it.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/chicken-more-macros.scm

    r7915 r7921  
    377377                 (let ([b (##sys#slot bs 0)]
    378378                       [bs2 (##sys#slot bs 1)] )
    379                    (cond [(not (pair? b)) `(if ,b ,(fold bs2) #f)]
     379                   (cond [(not-pair? b) `(if ,b ,(fold bs2) #f)]
    380380                         [(null? (##sys#slot b 1)) `(if ,(##sys#slot b 0) ,(fold bs2) #f)]
    381381                         [else
     
    634634
    635635(define-macro (case-lambda . clauses)
    636     (let ((args   (gensym))
    637           (tblv   (gensym))
    638           (cntv   (gensym)))
    639         (define ptbl
    640             (let loop ((l   clauses)
    641                        (m   #f)
    642                        (e   (lambda m    (error 'case-lambda (apply conc m))))
    643                        (w   (lambda m    (##sys#warn (apply conc m))))
    644                        (r   '()))
    645                 (cond ((null? l)
    646                           (if (null? r)
    647                               (e "not enough arguments: no clauses given.")
    648                               (map
    649                                   (lambda (x)
    650                                       `(cons ,(car x) ,(caddr x)))
    651                                   (reverse r))))
    652                       ((and (list? (car l)) (> (length (car l)) 1))
    653                           (let* ((la   (caar l))
    654                                  (ld   (cdar l))
    655                                  (al   (car l))
    656                                  (ll   (or (and (pair? la) (length la)) 0))
    657                                  (ck   `(cons ,ll ,(not (list? la))))
    658                                  (cp   `(lambda ,la ,@ld)))
    659                               (cond ((symbol? la)
    660                                         (or (null? (cdr l))
    661                                             (w "rest clause found with "
    662                                                (length (cdr l))
    663                                                " following clauses - "
    664                                                "skipping them."))
    665                                         (loop '() 0 e w
    666                                               (cons `(,ck ',al ,cp) r)))
    667                                     ((and (not (pair? la)) (not (null? la)))
    668                                         (e "invalid lambda list: " la))
    669                                     ((and m (fx<= m ll))
    670                                         (w "prior clause with fewer req args "
    671                                            "and rest arg: skipping clause "
    672                                            al)
    673                                         (loop (cdr l) m e w r))
    674                                     ((assoc ck r)
    675                                         (w "prior clause with same signature - "
    676                                            "skipping clause " al)
    677                                         (loop (cdr l) m e w r))
    678                                     ((not (list? la))
    679                                         (loop (cdr l) ll e w
    680                                               (cons `(,ck ',al ,cp) r)))
    681                                     (else
    682                                         (loop (cdr l) m e w
    683                                               (cons `(,ck ',al ,cp) r))))))
    684                       (else
    685                           (e "invalid clause: " (car l))))))
    686         `(lambda ,args
    687             (let loop ((,tblv   (list ,@ptbl))
    688                        (,cntv   (length ,args)))
    689                 (if (null? ,tblv)
    690                     (error 'case-lambda
    691                            (conc "no matching clause in call to case-lambda: "
    692                                  "arity - " ,cntv "  , args - " ,args))
    693                     (if (or (fx= (caaar ,tblv) ,cntv)
    694                             (and (cdaar ,tblv) (fx< (caaar ,tblv) ,cntv)))
    695                         (##sys#apply (cdar ,tblv) ,args)
    696                         (loop (cdr ,tblv) ,cntv)))))))
    697 
     636  (define (genvars n)
     637    (let loop ([i 0])
     638      (if (fx>= i n)
     639          '()
     640          (cons (gensym) (loop (fx+ i 1))) ) ) )
     641  (##sys#check-syntax 'case-lambda clauses '#(_ 0))
     642  (require 'srfi-1)                     ; Urgh...
     643  (let* ((mincount (apply min (map (lambda (c)
     644                                     (##sys#decompose-lambda-list
     645                                      (car c)
     646                                      (lambda (vars argc rest) argc) ) )
     647                                   clauses) ) )
     648         (minvars (genvars mincount))
     649         (rvar (gensym))
     650         (lvar (gensym)) )
     651    `(lambda ,(append minvars rvar)
     652       (let ((,lvar (length ,rvar)))
     653         ,(fold-right
     654           (lambda (c body)
     655             (##sys#decompose-lambda-list
     656              (car c)
     657              (lambda (vars argc rest)
     658                (##sys#check-syntax 'case-lambda (car c) 'lambda-list)
     659                `(if ,(let ([a2 (fx- argc mincount)])
     660                        (if rest
     661                            (if (zero? a2)
     662                                #t
     663                                `(fx>= ,lvar ,a2) )
     664                            `(fx= ,lvar ,a2) ) )
     665                     ,(receive
     666                       (vars1 vars2) (split-at! (take vars argc) mincount)
     667                       (let ((bindings
     668                              (let build ((vars2 vars2) (vrest rvar))
     669                                (if (null? vars2)
     670                                    (cond (rest `(let ((,rest ,vrest)) ,@(cdr c)))
     671                                          ((null? (cddr c)) (cadr c))
     672                                          (else `(let () ,@(cdr c))) )
     673                                    (let ((vrest2 (gensym)))
     674                                      `(let ((,(car vars2) (car ,vrest))
     675                                             (,vrest2 (cdr ,vrest)) )
     676                                         ,(if (pair? (cdr vars2))
     677                                              (build (cdr vars2) vrest2)
     678                                              (build '() vrest2) ) ) ) ) ) ) )
     679                         (if (null? vars1)
     680                             bindings
     681                             `(let ,(map list vars1 minvars) ,bindings) ) ) )
     682                     ,body) ) ) )
     683           '(##core#check (##sys#error (##core#immutable '"no matching clause in call to 'case-lambda' form")))
     684           clauses) ) ) ) )
    698685
    699686
     
    724711
    725712(define-macro (condition-case exp . clauses)
    726   (let* ([exvar (gensym)]
    727          [ccvar (gensym)]
    728          [evar (gensym)]
    729          [elsvar (gensym)]
    730          [elsbod `((##sys#apply ##sys#values ,elsvar))]
    731          [kvar (gensym)] )
     713  (let ([exvar (gensym)]
     714        [kvar (gensym)] )
    732715    (define (parse-clause c)
    733       (let* ([els (and (symbol? (car c)) (eq? 'else (car c)))]
    734              [var (and (symbol? (car c)) (car c))]
     716      (let* ([var (and (symbol? (car c)) (car c))]
    735717             [kinds (if var (cadr c) (car c))]
    736718             [body (if var (cddr c) (cdr c))] )
    737         (if els
    738             (begin
    739                 (set! elsvar kinds)
    740                 (set! elsbod body)
    741                 `(#f   #f))
    742             (if (null? kinds)
    743                 `(else
    744                   ,(if var
    745                        `(let ([,var ,exvar]) (,ccvar (begin ,@body)))
    746                        `(let () (,ccvar (begin ,@body))) ) )
    747                 `((and ,kvar ,@(map (lambda (k) `(memv ',k ,kvar)) kinds))
    748                   ,(if var
    749                        `(let ([,var ,exvar]) (,ccvar (begin ,@body)))
    750                        `(let () (,ccvar (begin ,@body))) ) ) ) ) ) )
    751     `(call-with-current-continuation
    752         (lambda (,ccvar)
    753             (##sys#call-with-values
    754                 (lambda ()
    755                     (handle-exceptions
    756                         ,exvar
    757                         (let ((,kvar   (and (##sys#structure? ,exvar 'condition)
    758                                             (##sys#slot ,exvar 1))))
    759                             (cond ,@(map parse-clause clauses)
    760                                   (else    (##sys#signal ,exvar))))
    761                         ,exp))
    762                 (lambda ,evar
    763                     (##sys#apply (lambda ,elsvar ,@elsbod) ,evar)))))))
     719        (if (null? kinds)
     720            `(else
     721              ,(if var
     722                   `(let ([,var ,exvar]) ,@body)
     723                   `(let () ,@body) ) )
     724            `((and ,kvar ,@(map (lambda (k) `(memv ',k ,kvar)) kinds))
     725              ,(if var
     726                   `(let ([,var ,exvar]) ,@body)
     727                   `(let () ,@body) ) ) ) ) )
     728    `(handle-exceptions ,exvar
     729         (let ([,kvar (and (##sys#structure? ,exvar 'condition) (##sys#slot ,exvar 1))])
     730           (cond ,@(map parse-clause clauses)
     731                 (else (##sys#signal ,exvar)) ) )
     732       ,exp) ) )
    764733
    765734
Note: See TracChangeset for help on using the changeset viewer.