gistfile1.txt

(library (Compiler contracts)
  (export UVar/c
          FVar/c
          Label/c
          Relop/c
          Binop/c
          DispOp/c
          Index/c
          Int32/c
          Int64/c
          UInt6/c
          Reg/c
          Int/c
          any/c or/c and/c
          define/c
          k/c
          listof
          pairof)
  (import 
   ;; Load Chez Scheme primitives:
   (chezscheme)
   ;; Load provided compiler framework:
   (Framework match)
   (Framework helpers)
   (Framework wrappers)
   (Framework prims)
   (Compiler tools))
  
  ;; Function Contracts

  (define-syntax (SCHEME-COMPILER-DEBUG stx)
    (syntax-case stx ()
       [(_) #t]))
  
  (define-syntax (define/c stx)
    (if (SCHEME-COMPILER-DEBUG)
        (syntax-case stx (->)
          [(_ (name args  ...)
              (argchecks ... ->)
              body ...)
           #'(define (name args ...)
               (begin (for-each 
                       (lambda (i f a) 
                         (unless (f a)
                           (errorf 'name "invalid argument[~a] ~s" i a)))
                       (iota (length (list args ...)))
                       (list argchecks ...)
                       (list args ...)))
               (begin body ...))]
          [(_ (name args  ...)
              (argchecks ... -> retcheck)
              body ...)
           #'(define (name args ...)
               (begin (for-each 
                       (lambda (i f a) 
                         (unless (f a)
                           (errorf 'name "invalid argument[~a] ~s" i a)))
                       (iota (length (list args ...)))
                       (list argchecks ...)
                       (list args ...)))
               (let ([val (begin body ...)])
                 (unless (retcheck val)
                   (errorf 'name "invalid return value ~s" val))
                 val))]
          [(_ (name args  ...)
              (argchecks ... -> retcheck1 retcheck2)
              body ...)
           #'(define (name args ...)
               (begin (for-each 
                       (lambda (i f a) 
                         (unless (f a)
                           (errorf 'name "invalid argument[~a] ~s" i a)))
                       (iota (length (list args ...)))
                       (list argchecks ...)
                       (list args ...)))
               (let-values ([(val1 val2) (begin body ...)])
                 (unless (and (retcheck1 val1) (retcheck2 val2))
                   (errorf 'name "invalid return values: ~s ~s" val1 val2))
                 (values val1 val2)))])
        (syntax-case stx (->)
          [(_ (name args  ...)
              (argchecks ... -> retcheck)
              body ...)
           #'(define (name args ...) body ...)]
          [(_ (name args  ...)
              (argchecks ... ->)
              body ...)
           #'(define (name args ...) body ...)])))
  
  ;; *** useful generic contracts ***
  
  (define (any/c _) #t)
  
  (define-syntax (or/c stx)
    (syntax-case stx ()
      [(_) #'(λ (_) #f)]
      [(or/c c0 c1 ...) 
       #'(lambda (x) (or (c0 x)
                         ((or/c c1 ...) x)))]))
  
(define-syntax (and/c stx)
    (syntax-case stx ()
      [(_) #'(λ (_) #t)]
      [(or/c c0 c1 ...) 
       #'(lambda (x) (and (c0 x)
                          ((and/c c1 ...) x)))]))

(define-syntax (listof stx)
    (syntax-case stx ()
      [(_ c?) 
       #'(lambda (x) (andmap c? x))]))

(define-syntax (pairof stx)
  (syntax-case stx ()
    [(_ lhs? rhs?) 
     #'(lambda (x) (and (pair? x)
                        (lhs? (car x)) 
                        (rhs? (cdr x))))]))

(define k/c procedure?)

;; *** Language Prim Contracts ***

(define UVar/c isUVar)
(define FVar/c isFVar)
(define Label/c isLabel)
(define Relop/c isRelop)
(define Binop/c isBinop)
(define DispOp/c disp-opnd?)
(define Index/c index-opnd?)
(define Int32/c int32?)
(define Int64/c int64?)
(define UInt6/c uint6?)
(define Reg/c isReg)
(define Int/c integer?)


)