Changeset 15588 in project


Ignore:
Timestamp:
08/27/09 23:40:03 (10 years ago)
Author:
kon
Message:

Added 'make-error-type-message' & fixed 'define-check+error-type'.

Location:
release/4/check-errors/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/check-errors/trunk/check-errors.meta

    r14084 r15588  
    1010 (files
    1111  "tests"
     12  "type-errors.scm"
    1213  "chicken-primitive-object-inlines.scm"
     14  "type-checks"
    1315  "inline-type-checks.scm"
    14   "type-errors.scm"
    1516  "conditions.scm"
    1617  "check-errors.setup") )
  • release/4/check-errors/trunk/conditions.scm

    r14288 r15588  
    2121  (make-condition-property-accessor condition-property-accessor*))
    2222
    23 (import scheme chicken (only srfi-1 alist-cons) #;srfi-12 type-checks)
    24 (require-library srfi-1 #;srfi-12 type-checks)
     23(import scheme chicken (only srfi-1 alist-cons) srfi-12 type-checks)
     24(require-library srfi-1 srfi-12 type-checks)
    2525
    2626;;
  • release/4/check-errors/trunk/tests/run.scm

    r14288 r15588  
    6464(test 23 (testc-extra-test testc))
    6565(test 'foobar (testc-extra-foo testc))
     66
     67(define (foo? obj) #t)
     68(define-check+error-type foo)
     69(test-assert error-foo)
     70(test-assert check-foo)
     71(define-check+error-type foo1 foo?)
     72(test-assert error-foo1)
     73(test-assert check-foo1)
     74(define-check+error-type foo2 foo? "foodie")
     75(test-assert error-foo2)
     76(test-assert check-foo2)
  • release/4/check-errors/trunk/type-checks.scm

    r14139 r15588  
    144144;;
    145145
     146; <type-symbol> [<type-predicate> [<message-string>]]
     147
    146148(define-syntax define-check+error-type
    147149  (lambda (form r c)
    148150    (let (($define-check-type (r 'define-check-type))
    149151          ($define-error-type (r 'define-error-type)) )
    150       (let ((typ (cadr form)))
     152      (let* ((typ (cadr form))
     153             (pred (and (not (null? (cddr form))) (caddr form)))
     154             (mesg (and pred (not (null? (cdddr form))) (cadddr form))) )
    151155        `(begin
    152            (,$define-check-type ,typ)
    153            (,$define-error-type ,typ) ) ) ) ) )
     156           (,$define-error-type ,typ ,@(if mesg `(,mesg) '()))
     157           (,$define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) )
    154158
    155159) ;module type-checks
  • release/4/check-errors/trunk/type-errors.scm

    r14230 r15588  
    11;;;; type-errors.scm
    22;;;; Kon Lovett, Apr '09
    3 
    4 (declare
    5   (usual-integrations)
    6   (fixnum)
    7   (inline)
    8   (local)
    9   (no-procedure-checks)
    10   (no-bound-checks)
    11   (bound-to-procedure
    12     ##sys#signal-hook) )
    133
    144;;;
     
    177  ;;
    188  error-argument-type
     9  make-error-type-message
    1910  ;;
    2011  error-fixnum
     
    4637(import scheme chicken (only data-structures ->string conc))
    4738
     39(declare
     40  (usual-integrations)
     41  (fixnum)
     42  (inline)
     43  (local)
     44  (no-procedure-checks)
     45  (no-bound-checks)
     46  (constant
     47    vowel?)
     48  (bound-to-procedure
     49    ##sys#signal-hook) )
     50
    4851;;;
    4952
     
    5255(define (vowel? ch) (and (memq ch '(#\a #\e #\i #\o #\u)) #t))
    5356
     57(define (make-error-type-message kndnam #!optional argnam)
     58  (let ((kndnam (->string kndnam)))
     59    (conc
     60      "bad"
     61      #\space (if argnam (conc #\` argnam #\' #\space) "")
     62      "argument type - not"
     63      #\space (if (vowel? (string-ref kndnam 0)) "an" "a")
     64      #\space kndnam) ) )
     65
    5466(define (error-argument-type loc obj kndnam #!optional argnam)
    55   (let ((kndnam (->string kndnam)))
    56     (##sys#signal-hook #:type-error
    57                        loc
    58                        (conc "bad"
    59                              #\space (if argnam (conc #\` argnam #\' #\space) "")
    60                              "argument type - not"
    61                              #\space (if (vowel? (string-ref kndnam 0)) "an" "a")
    62                              #\space kndnam)
    63                        obj) ) )
     67  (##sys#signal-hook #:type-error loc (make-error-type-message kndnam argnam) obj) )
    6468
    6569;;
Note: See TracChangeset for help on using the changeset viewer.