Changeset 7915 in project


Ignore:
Timestamp:
01/24/08 07:27:34 (12 years ago)
Author:
elf
Message:

a fix for the srfi-1 requirement in case-lambda, as well as removing the
dependency on the eval unit, i believe.

File:
1 edited

Legend:

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

    r7879 r7915  
    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   (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) ) ) ) )
     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
    685698
    686699
Note: See TracChangeset for help on using the changeset viewer.