Changeset 15997 in project


Ignore:
Timestamp:
09/20/09 22:12:43 (10 years ago)
Author:
Kon Lovett
Message:

Rel 1.5.0

Location:
release/4/check-errors
Files:
6 edited
5 copied

Legend:

Unmodified
Added
Removed
  • release/4/check-errors/tags/1.5.0/inline-type-checks.scm

    r14186 r15997  
    33
    44;; Needs "chicken-primitive-object-inlines.scm"
     5;; This source is to be included
    56
    67;;
    78
    89(cond-expand
     10
    911  (unsafe
    1012 
    1113    (define-syntax define-inline-check-type
    1214      (lambda (form r c)
    13         (let (($define-inline (r 'define-inline)))
     15        (let ((_define-inline (r 'define-inline)))
    1416          (let* ((typ (cadr form))
    1517                 (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
    16             `(,$define-inline (,nam . _) (begin) ) ) ) ) )
     18            `(,_define-inline (,nam . _) (begin) ) ) ) ) )
    1719
    1820    (define-inline (%check-positive-fixnum . _) (begin))
     
    2224    (define-inline (%check-positive-number . _) (begin))
    2325    (define-inline (%check-cardinal-number . _) (begin))
    24     (define-inline (%check-structure . _) (begin)) )
     26    (define-inline (%check-structure . _) (begin))
     27    (define-inline (%check-minimum-argument-count . _) (begin))
     28    (define-inline (%check-argument-count . _) (begin)) )
    2529
    2630  (else
     31
     32    (define (%alist? obj)
     33      (or (%null? obj)
     34          (and (%pair? obj) (%list-every/1 (lambda (x) (%pair? x)) obj))) )
    2735
    2836    ;;
     
    3038    (define-syntax define-inline-check-type
    3139      (lambda (form r c)
    32         (let (($define-inline (r 'define-inline))
    33               ($#!optional (r '#!optional)) )
     40        (let ((_define-inline (r 'define-inline))
     41              (_#!optional (r '#!optional)) )
    3442          (let* ((typ (cadr form))
    3543                 (typstr (symbol->string typ))
    36                  (pred (if (not (null? (cddr form))) (caddr form) (string->symbol (string-append "%" typstr "?"))))
     44                 (pred (if (not (null? (cddr form))) (caddr form)
     45                           (string->symbol (string-append "%" typstr "?"))))
    3746                 (nam (string->symbol (string-append "%check-" typstr)))
    3847                 (errnam (string->symbol (string-append "error-" typstr))) )
    39             `(,$define-inline (,nam loc obj ,$#!optional argnam)
     48            `(,_define-inline (,nam loc obj ,_#!optional argnam)
    4049               (unless (,pred obj)
    4150                 (,errnam loc obj argnam) ) ) ) ) ) )
     
    7584    (define-inline (%check-structure loc obj tag #!optional argnam)
    7685      (unless (%structure-instance? obj tag)
    77         (error-structure loc obj tag argnam) ) ) ) )
     86        (error-structure loc obj tag argnam) ) )
     87
     88    ;;
     89
     90    (define-inline (%check-minimum-argument-count loc argc minargc)
     91      (unless (%fx<= minargc argc)
     92        (error-minimum-argument-count loc argc minargc)) )
     93
     94    (define-inline (%check-argument-count loc argc maxargc)
     95      (unless (%fx<= argc maxargc)
     96        (error-argument-count loc argc maxargc)) ) ) )
    7897
    7998;;
     
    95114(define-inline-check-type blob)
    96115(define-inline-check-type vector)
     116(define-inline-check-type alist)
  • release/4/check-errors/tags/1.5.0/tests/run.scm

    r15588 r15997  
    2424(test-error (check-char 'test 'x))
    2525(test-error (check-boolean 'test 'x))
     26(test-error (check-alist 'test 'x))
     27(test-error (check-alist 'test '(23)))
     28(test-error (check-alist 'test '((a . 1) ())))
     29(test-error (check-minimum-argument-count 'test 0 1))
     30(test-error (check-argument-count 'test 1 0))
    2631
     32;should produce no output
    2733(check-fixnum 'test 1)
    2834(check-positive-fixnum 'test 1)
     
    5460(check-char 'test #\x)
    5561(check-boolean 'test #t)
     62(check-alist 'test '())
     63(check-alist 'test '((a . 1)))
     64(check-alist 'test '((a . 1) (b . 2)))
     65(check-minimum-argument-count 'test 1 1)
     66(check-argument-count 'test 1 1)
    5667
    5768(define testc (make-exn-condition+ 'test "test" '(test) 'test '(extra test 23)))
  • release/4/check-errors/tags/1.5.0/type-checks.scm

    r15995 r15997  
    3030  check-alist
    3131  ;;
    32   define-check-type define-check+error-type
     32  check-minimum-argument-count
     33  check-argument-count
    3334  ;;
    34   check-minimum-argument-count
    35   check-argument-count)
     35  define-check-type define-check+error-type)
    3636
    3737  (import chicken scheme (only srfi-1 every) type-errors)
     
    4949    (define-syntax define-check-type
    5050      (lambda (form r c)
    51         (let (($define (r 'define)))
     51        (let ((_define (r 'define)))
    5252          (let* ((typ (cadr form))
    5353                 (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
    54             `(,$define (,nam . _) (begin) ) ) ) ) )
     54            `(,_define (,nam . _) (begin) ) ) ) ) )
    5555
    5656    (define (check-positive-fixnum . _) (begin))
     
    7575    (define-syntax define-check-type
    7676      (lambda (form r c)
    77         (let (($define (r 'define))
    78               ($#!optional (r '#!optional)) )
     77        (let ((_define (r 'define))
     78              (_#!optional (r '#!optional)) )
    7979          (let* ((typ (cadr form))
    8080                 (typstr (symbol->string typ))
     
    8282                 (nam (string->symbol (string-append "check-" typstr)))
    8383                 (errnam (string->symbol (string-append "error-" typstr))) )
    84             `(,$define (,nam loc obj ,$#!optional argnam)
     84            `(,_define (,nam loc obj ,_#!optional argnam)
    8585               (unless (,pred obj)
    8686                 (,errnam loc obj argnam) ) ) ) ) ) )
     
    143143(define-check-type alist)
    144144
    145 (define (check-minimum-argument-count loc actargc minargc)
    146   (unless (<= minargc actargc)
    147     (error-minimum-argument-count loc actargc minargc)) )
     145(define (check-minimum-argument-count loc argc minargc)
     146  (unless (fx<= minargc argc)
     147    (error-minimum-argument-count loc argc minargc)) )
    148148
    149 (define (check-argument-count loc actargc maxargc)
    150   (unless (<= actargc maxargc)
    151     (error-argument-count loc actargc maxargc)) )
     149(define (check-argument-count loc argc maxargc)
     150  (unless (fx<= argc maxargc)
     151    (error-argument-count loc argc maxargc)) )
    152152
    153153;;
     
    157157(define-syntax define-check+error-type
    158158  (lambda (form r c)
    159     (let (($define-check-type (r 'define-check-type))
    160           ($define-error-type (r 'define-error-type)) )
     159    (let ((_define-check-type (r 'define-check-type))
     160          (_define-error-type (r 'define-error-type)) )
    161161      (let* ((typ (cadr form))
    162162             (pred (and (not (null? (cddr form))) (caddr form)))
    163163             (mesg (and pred (not (null? (cdddr form))) (cadddr form))) )
    164164        `(begin
    165            (,$define-error-type ,typ ,@(if mesg `(,mesg) '()))
    166            (,$define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) )
     165           (,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
     166           (,_define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) )
    167167
    168168) ;module type-checks
  • release/4/check-errors/tags/1.5.0/type-errors.scm

    r15995 r15997  
    9393(define-syntax define-error-type
    9494  (lambda (form r c)
    95     (let (($define (r 'define))
    96           ($#!optional (r '#!optional))
    97           ($error-argument-type (r 'error-argument-type)) )
     95    (let ((_define (r 'define))
     96          (_#!optional (r '#!optional))
     97          (_error-argument-type (r 'error-argument-type)) )
    9898      (let* ((typ (cadr form))
    9999             (typstr (symbol->string typ))
    100100             (msg (if (null? (cddr form)) typstr (caddr form)))
    101101             (nam (string->symbol (string-append "error-" typstr))) )
    102         `(,$define (,nam loc obj ,$#!optional argnam)
    103            (,$error-argument-type loc obj ,msg argnam) ) ) ) ) )
     102        `(,_define (,nam loc obj ,_#!optional argnam)
     103           (,_error-argument-type loc obj ,msg argnam) ) ) ) ) )
    104104
    105105;;
     
    133133(define-error-type alist "association-list")
    134134
    135 (define (error-minimum-argument-count loc argcnt cnt)
    136   (##sys#error-hook (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int) loc argcnt cnt) )
     135(define (error-minimum-argument-count loc argc minargc)
     136  (##sys#error-hook (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int) loc minargc argc) )
    137137
    138 (define (error-argument-count loc argcnt cnt)
    139   (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_COUNT_ERROR" int) loc argcnt cnt) )
     138(define (error-argument-count loc argc maxargc)
     139  (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_COUNT_ERROR" int) loc maxargc argc) )
    140140
    141141) ;module type-errors
  • release/4/check-errors/trunk/inline-type-checks.scm

    r14186 r15997  
    33
    44;; Needs "chicken-primitive-object-inlines.scm"
     5;; This source is to be included
    56
    67;;
    78
    89(cond-expand
     10
    911  (unsafe
    1012 
    1113    (define-syntax define-inline-check-type
    1214      (lambda (form r c)
    13         (let (($define-inline (r 'define-inline)))
     15        (let ((_define-inline (r 'define-inline)))
    1416          (let* ((typ (cadr form))
    1517                 (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
    16             `(,$define-inline (,nam . _) (begin) ) ) ) ) )
     18            `(,_define-inline (,nam . _) (begin) ) ) ) ) )
    1719
    1820    (define-inline (%check-positive-fixnum . _) (begin))
     
    2224    (define-inline (%check-positive-number . _) (begin))
    2325    (define-inline (%check-cardinal-number . _) (begin))
    24     (define-inline (%check-structure . _) (begin)) )
     26    (define-inline (%check-structure . _) (begin))
     27    (define-inline (%check-minimum-argument-count . _) (begin))
     28    (define-inline (%check-argument-count . _) (begin)) )
    2529
    2630  (else
     31
     32    (define (%alist? obj)
     33      (or (%null? obj)
     34          (and (%pair? obj) (%list-every/1 (lambda (x) (%pair? x)) obj))) )
    2735
    2836    ;;
     
    3038    (define-syntax define-inline-check-type
    3139      (lambda (form r c)
    32         (let (($define-inline (r 'define-inline))
    33               ($#!optional (r '#!optional)) )
     40        (let ((_define-inline (r 'define-inline))
     41              (_#!optional (r '#!optional)) )
    3442          (let* ((typ (cadr form))
    3543                 (typstr (symbol->string typ))
    36                  (pred (if (not (null? (cddr form))) (caddr form) (string->symbol (string-append "%" typstr "?"))))
     44                 (pred (if (not (null? (cddr form))) (caddr form)
     45                           (string->symbol (string-append "%" typstr "?"))))
    3746                 (nam (string->symbol (string-append "%check-" typstr)))
    3847                 (errnam (string->symbol (string-append "error-" typstr))) )
    39             `(,$define-inline (,nam loc obj ,$#!optional argnam)
     48            `(,_define-inline (,nam loc obj ,_#!optional argnam)
    4049               (unless (,pred obj)
    4150                 (,errnam loc obj argnam) ) ) ) ) ) )
     
    7584    (define-inline (%check-structure loc obj tag #!optional argnam)
    7685      (unless (%structure-instance? obj tag)
    77         (error-structure loc obj tag argnam) ) ) ) )
     86        (error-structure loc obj tag argnam) ) )
     87
     88    ;;
     89
     90    (define-inline (%check-minimum-argument-count loc argc minargc)
     91      (unless (%fx<= minargc argc)
     92        (error-minimum-argument-count loc argc minargc)) )
     93
     94    (define-inline (%check-argument-count loc argc maxargc)
     95      (unless (%fx<= argc maxargc)
     96        (error-argument-count loc argc maxargc)) ) ) )
    7897
    7998;;
     
    95114(define-inline-check-type blob)
    96115(define-inline-check-type vector)
     116(define-inline-check-type alist)
  • release/4/check-errors/trunk/tests/run.scm

    r15588 r15997  
    2424(test-error (check-char 'test 'x))
    2525(test-error (check-boolean 'test 'x))
     26(test-error (check-alist 'test 'x))
     27(test-error (check-alist 'test '(23)))
     28(test-error (check-alist 'test '((a . 1) ())))
     29(test-error (check-minimum-argument-count 'test 0 1))
     30(test-error (check-argument-count 'test 1 0))
    2631
     32;should produce no output
    2733(check-fixnum 'test 1)
    2834(check-positive-fixnum 'test 1)
     
    5460(check-char 'test #\x)
    5561(check-boolean 'test #t)
     62(check-alist 'test '())
     63(check-alist 'test '((a . 1)))
     64(check-alist 'test '((a . 1) (b . 2)))
     65(check-minimum-argument-count 'test 1 1)
     66(check-argument-count 'test 1 1)
    5667
    5768(define testc (make-exn-condition+ 'test "test" '(test) 'test '(extra test 23)))
  • release/4/check-errors/trunk/type-checks.scm

    r15995 r15997  
    3030  check-alist
    3131  ;;
    32   define-check-type define-check+error-type
     32  check-minimum-argument-count
     33  check-argument-count
    3334  ;;
    34   check-minimum-argument-count
    35   check-argument-count)
     35  define-check-type define-check+error-type)
    3636
    3737  (import chicken scheme (only srfi-1 every) type-errors)
     
    4949    (define-syntax define-check-type
    5050      (lambda (form r c)
    51         (let (($define (r 'define)))
     51        (let ((_define (r 'define)))
    5252          (let* ((typ (cadr form))
    5353                 (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
    54             `(,$define (,nam . _) (begin) ) ) ) ) )
     54            `(,_define (,nam . _) (begin) ) ) ) ) )
    5555
    5656    (define (check-positive-fixnum . _) (begin))
     
    7575    (define-syntax define-check-type
    7676      (lambda (form r c)
    77         (let (($define (r 'define))
    78               ($#!optional (r '#!optional)) )
     77        (let ((_define (r 'define))
     78              (_#!optional (r '#!optional)) )
    7979          (let* ((typ (cadr form))
    8080                 (typstr (symbol->string typ))
     
    8282                 (nam (string->symbol (string-append "check-" typstr)))
    8383                 (errnam (string->symbol (string-append "error-" typstr))) )
    84             `(,$define (,nam loc obj ,$#!optional argnam)
     84            `(,_define (,nam loc obj ,_#!optional argnam)
    8585               (unless (,pred obj)
    8686                 (,errnam loc obj argnam) ) ) ) ) ) )
     
    143143(define-check-type alist)
    144144
    145 (define (check-minimum-argument-count loc actargc minargc)
    146   (unless (<= minargc actargc)
    147     (error-minimum-argument-count loc actargc minargc)) )
     145(define (check-minimum-argument-count loc argc minargc)
     146  (unless (fx<= minargc argc)
     147    (error-minimum-argument-count loc argc minargc)) )
    148148
    149 (define (check-argument-count loc actargc maxargc)
    150   (unless (<= actargc maxargc)
    151     (error-argument-count loc actargc maxargc)) )
     149(define (check-argument-count loc argc maxargc)
     150  (unless (fx<= argc maxargc)
     151    (error-argument-count loc argc maxargc)) )
    152152
    153153;;
     
    157157(define-syntax define-check+error-type
    158158  (lambda (form r c)
    159     (let (($define-check-type (r 'define-check-type))
    160           ($define-error-type (r 'define-error-type)) )
     159    (let ((_define-check-type (r 'define-check-type))
     160          (_define-error-type (r 'define-error-type)) )
    161161      (let* ((typ (cadr form))
    162162             (pred (and (not (null? (cddr form))) (caddr form)))
    163163             (mesg (and pred (not (null? (cdddr form))) (cadddr form))) )
    164164        `(begin
    165            (,$define-error-type ,typ ,@(if mesg `(,mesg) '()))
    166            (,$define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) )
     165           (,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
     166           (,_define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) )
    167167
    168168) ;module type-checks
  • release/4/check-errors/trunk/type-errors.scm

    r15995 r15997  
    9393(define-syntax define-error-type
    9494  (lambda (form r c)
    95     (let (($define (r 'define))
    96           ($#!optional (r '#!optional))
    97           ($error-argument-type (r 'error-argument-type)) )
     95    (let ((_define (r 'define))
     96          (_#!optional (r '#!optional))
     97          (_error-argument-type (r 'error-argument-type)) )
    9898      (let* ((typ (cadr form))
    9999             (typstr (symbol->string typ))
    100100             (msg (if (null? (cddr form)) typstr (caddr form)))
    101101             (nam (string->symbol (string-append "error-" typstr))) )
    102         `(,$define (,nam loc obj ,$#!optional argnam)
    103            (,$error-argument-type loc obj ,msg argnam) ) ) ) ) )
     102        `(,_define (,nam loc obj ,_#!optional argnam)
     103           (,_error-argument-type loc obj ,msg argnam) ) ) ) ) )
    104104
    105105;;
     
    133133(define-error-type alist "association-list")
    134134
    135 (define (error-minimum-argument-count loc argcnt cnt)
    136   (##sys#error-hook (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int) loc argcnt cnt) )
     135(define (error-minimum-argument-count loc argc minargc)
     136  (##sys#error-hook (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int) loc minargc argc) )
    137137
    138 (define (error-argument-count loc argcnt cnt)
    139   (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_COUNT_ERROR" int) loc argcnt cnt) )
     138(define (error-argument-count loc argc maxargc)
     139  (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_COUNT_ERROR" int) loc maxargc argc) )
    140140
    141141) ;module type-errors
Note: See TracChangeset for help on using the changeset viewer.