Changeset 14280 in project


Ignore:
Timestamp:
04/17/09 11:50:07 (11 years ago)
Author:
felix winkelmann
Message:

small report fixes and initial support for #!optional

Location:
chicken/branches/scrutiny
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/scrutiny/TODO

    r13968 r14280  
    111111** scrutiny
    112112*** document type-specifiers
    113 *** handle #!optional in procedure type signatures
    114113*** allow giving toplevel procedure names to `scrutinize' option?
    115114
  • chicken/branches/scrutiny/scrutinizer.scm

    r13990 r14280  
    8383;   VAL = (or VAL1 ...)
    8484;       | (struct NAME)
    85 ;       | (procedure (VAL1 ... [#!rest [VAL]]) . RESULTS)
     85;       | (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL]]) . RESULTS)
    8686;       | BASIC
    87 ;   BASIC = * | string | symbol | char | number | boolean | list | pair | procedure | vector | void | null | eof | undefined
     87;   BASIC = * | string | symbol | char | number | boolean | list | pair |
     88;           procedure | vector | void | null | eof | undefined | port
    8889;   RESULTS = *
    8990;           | (VAL1 ...)
     
    224225        (and (memq t1 '(pair list))
    225226             (memq t2 '(pair list)))
     227        (and (memq t1 '(null list))
     228             (memq t2 '(null list)))
    226229        (and (pair? t1) (pair? t2)
    227230             (or (and (eq? (car t1) 'or)
     
    242245  (define (match-args args1 args2)
    243246    (d "match-args: ~s <-> ~s" args1 args2)
    244     (define (match-rest rtype args)
     247    (define (match-rest rtype args opt) ;XXX currently ignores `opt'
    245248      (let-values (((head tail) (break (cut eq? '#!rest <>) args)))
    246249        (and (every (cut match rtype <>) head) ; match required args
     
    252255    (define (optargs a)
    253256      (memq a '(#!rest #!optional)))
    254     (let loop ((args1 args1) (args2 args2))
     257    (let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f))
    255258      (cond ((null? args1)
    256              (or (null? args2)
     259             (or opt2
     260                 (null? args2)
    257261                 (optargs (car args2))))
    258             ((null? args2) (optargs (car args2)))
     262            ((null? args2) (or opt1 (optargs (car args2))))
     263            ((eq? '#!optional (car args1))
     264             (loop (cdr args1) args2 #t opt2))
     265            ((eq? '#!optional (car args2))
     266             (loop args1 (cdr args2) opt1 #t))
    259267            ((eq? '#!rest (car args1))
    260              (match-rest (if (pair? (cdr args1)) (cadr args1) '*) args2))
     268             (match-rest (if (pair? (cdr args1)) (cadr args1) '*) args2 opt2))
    261269            ((eq? '#!rest (car args2))
    262              (match-rest (if (pair? (cdr args2)) (cadr args2) '*) args1))
    263             ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2)))
     270             (match-rest (if (pair? (cdr args2)) (cadr args2) '*) args1 opt1))
     271            ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2) opt1 opt2))
    264272            (else #f))))
    265273  (define (check expected given loc what #!optional desc)
     
    294302      (if desc " " "")
    295303      (if expected
    296           (sprintf "expected ~a~a~a" (or what "") (and what " ") expected)
     304          (sprintf "expected ~a~a~a" (or what "") (if what " " "") expected)
    297305          "")
    298306      (sprintf ", but where given ~a" given))))
     
    340348            (report
    341349             loc
     350             (sprintf "~a argument~a" alen (multiples alen))
    342351             (sprintf "~a argument~a" nargs (multiples nargs))
    343              (sprintf "~a argument~a" alen (multiples alen))
    344352             (pname))))
    345353        (do ((args (cdr args) (cdr args))
     
    359367                              (third t)
    360368                              (second t)))
    361                       (m n))
     369                      (m n)
     370                      (opt #f))
    362371             (cond ((null? at) '())
     372                   ((eq? '#!optional (car at))
     373                    (loop (cdr at) m #t) )
    363374                   ((eq? '#!rest (car at))
    364375                    (if (pair? (cdr at))
    365376                        (make-list m (cadr at))
    366377                        (make-list m '*)))
    367                    (else (cons (car at) (loop (cdr at) (sub1 m)))))))
     378                   ((and opt (<= m 0)) '())
     379                   (else (cons (car at) (loop (cdr at) (sub1 m) opt))))))
    368380          (else (bomb "not a procedure type: ~a" t))))
    369381  (define (procedure-result-types t)
Note: See TracChangeset for help on using the changeset viewer.