Changeset 14744 in project


Ignore:
Timestamp:
05/22/09 16:19:24 (10 years ago)
Author:
felix winkelmann
Message:

basic hack for obtaining result values types in call to 'values'

Location:
chicken/branches/scrutiny
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/scrutiny/scrutinizer.scm

    r14715 r14744  
    8484;   VAL = (or VAL1 ...)
    8585;       | (struct NAME)
    86 ;       | (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL]]) . RESULTS)
     86;       | (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL | values]]) . RESULTS)
    8787;       | BASIC
    8888;       | deprecated
     
    268268         (eq? 'procedure (car t))
    269269         (not (or (null? (cadr t)) (pair? (cadr t))))))
     270  (define (rest-type r)
     271    (cond ((null? r) '*)
     272          ((eq? 'values (car r)) '*)
     273          (else (car r))))
    270274  (define (merge-argument-types ts1 ts2)
    271275    (cond ((null? ts1)
     
    277281                  `(#!rest
    278282                    ,(simplify
    279                       `(or ,(if (pair? (cdr ts1)) (cadr ts1) '*)
    280                            ,(if (pair? (cdr ts2)) (cadr ts2) '*)))))
     283                      `(or ,(rest-type (cdr ts1))
     284                           ,(rest-type (cdr ts2))))))
    281285                 (else '(#!rest))))             ;XXX giving up
    282286          ((eq? '#!optional (car ts1))
     
    328332      (let-values (((head tail) (break (cut eq? '#!rest <>) args)))
    329333        (and (every (cut match rtype <>) head) ; match required args
    330              (match
    331                  rtype
    332                (if (and (pair? tail) (pair? (cdr tail)))
    333                    (cadr tail)
    334                    '*) ) ) ) )
     334             (match rtype (if (pair? tail) (rest-type (cdr tail)) '*)))))
    335335    (define (optargs a)
    336336      (memq a '(#!rest #!optional)))
     
    349349             (loop args1 (cdr args2) opt1 #t))
    350350            ((eq? '#!rest (car args1))
    351              (match-rest (if (pair? (cdr args1)) (cadr args1) '*) args2 opt2))
     351             (match-rest (rest-type (cdr args1)) args2 opt2))
    352352            ((eq? '#!rest (car args2))
    353              (match-rest (if (pair? (cdr args2)) (cadr args2) '*) args1 opt1))
     353             (match-rest (rest-type (cdr args2)) args1 opt1))
    354354            ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2) opt1 opt2))
    355355            (else #f))))
     
    357357    (cond ((null? results1) (atom? results2))
    358358          ((eq? '* results1))
     359          ((eq? '* results2))
     360          ((eq? '* results2))
    359361          ((eq? '* results2))
    360362          ((null? results2) #f)
     
    480482         ptype
    481483         loc "a procedure of type" (pname)))
    482       (let ((atypes (procedure-argument-types ptype (length (cdr args)))))
    483         (d "  argument-types: ~a" atypes)
     484      (let-values (((atypes values-rest) (procedure-argument-types ptype (length (cdr args)))))
     485        (d "  argument-types: ~a (~a)" atypes values-rest)
    484486        (unless (= (length atypes) nargs)
    485487          (let ((alen (length atypes)))
     
    494496            ((or (null? args) (null? atypes)))
    495497          (check (car atypes) (car args) loc (sprintf "argument #~a of type" i) (pname)))
    496         (let ((r (procedure-result-types ptype)))
     498        (let ((r (procedure-result-types ptype values-rest (cdr args))))
    497499          (d  "  result-types: ~a" r)
    498500          r))))
     
    506508    (cond ((or (memq t '(* procedure))
    507509               (not-pair? t) )
    508            (make-list n '*))
     510           (values (make-list n '*) #f))
    509511          ((eq? 'procedure (car t))
    510512           (let loop ((at (if (or (string? (second t)) (symbol? (second t)))
     
    517519                    (loop (cdr at) m #t) )
    518520                   ((eq? '#!rest (car at))
    519                     (if (pair? (cdr at))
    520                         (make-list m (cadr at))
    521                         (make-list m '*)))
    522                    ((and opt (<= m 0)) '())
     521                    (values
     522                     (make-list m (rest-type (cdr at)))
     523                     (and (pair? (cdr at))
     524                          (eq? 'values (cadr at)))))
     525                   ((and opt (<= m 0)) (values '() #f))
    523526                   (else (cons (car at) (loop (cdr at) (sub1 m) opt))))))
    524527          (else (bomb "not a procedure type" t))))
    525   (define (procedure-result-types t)
    526     (cond ((or (memq t '(* procedure))
     528  (define (procedure-result-types t values-rest? args)
     529    (cond (values-rest? args)
     530          ((or (memq t '(* procedure))
    527531               (not-pair? t) )
    528532           '*)
  • chicken/branches/scrutiny/types.db

    r14715 r14744  
    209209(with-output-to-file (procedure with-output-to-file (string procedure) . *))
    210210(dynamic-wind (procedure dynamic-wind (procedure procedure procedure) . *))
    211 (values (procedure values (#!rest) . *))
     211(values (procedure values (#!rest values) . *))
    212212(call-with-values (procedure call-with-values (procedure procedure) . *))
    213213(eval (procedure eval (*) *))
Note: See TracChangeset for help on using the changeset viewer.