lib/_std#.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_std#.scm", Time-stamp: <2008-02-08 22:44:13 feeley>
   4
   5 ;;; Copyright (c) 1994-2008 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 ;;; Representation of exceptions.
  10
  11 (define-library-type-of-exception improper-length-list-exception
  12   id: 15d36810-b4bf-4609-83cc-761a8868e4a0
  13   constructor: #f
  14   opaque:
  15
  16   (procedure unprintable: read-only:)
  17   (arguments unprintable: read-only:)
  18   (arg-num   unprintable: read-only:)
  19 )
  20
  21 ;;;----------------------------------------------------------------------------
  22
  23 ;;; Define type checking macros.
  24
  25 (define-check-type string 'string
  26   ##string?)
  27
  28 (define-check-type string-list 'string-list
  29   ##string?)
  30
  31 (define-check-type vector 'vector
  32   ##vector?)
  33
  34 (define-check-type vector-list 'vector-list
  35   ##vector?)
  36
  37 (define-check-type s8vector 's8vector
  38   ##s8vector?)
  39
  40 (define-check-type s8vector-list 's8vector-list
  41   ##s8vector?)
  42
  43 (define-check-type u8vector 'u8vector
  44   ##u8vector?)
  45
  46 (define-check-type u8vector-list 'u8vector-list
  47   ##u8vector?)
  48
  49 (define-check-type s16vector 's16vector
  50   ##s16vector?)
  51
  52 (define-check-type s16vector-list 's16vector-list
  53   ##s16vector?)
  54
  55 (define-check-type u16vector 'u16vector
  56   ##u16vector?)
  57
  58 (define-check-type u16vector-list 'u16vector-list
  59   ##u16vector?)
  60
  61 (define-check-type s32vector 's32vector
  62   ##s32vector?)
  63
  64 (define-check-type s32vector-list 's32vector-list
  65   ##s32vector?)
  66
  67 (define-check-type u32vector 'u32vector
  68   ##u32vector?)
  69
  70 (define-check-type u32vector-list 'u32vector-list
  71   ##u32vector?)
  72
  73 (define-check-type s64vector 's64vector
  74   ##s64vector?)
  75
  76 (define-check-type s64vector-list 's64vector-list
  77   ##s64vector?)
  78
  79 (define-check-type u64vector 'u64vector
  80   ##u64vector?)
  81
  82 (define-check-type u64vector-list 'u64vector-list
  83   ##u64vector?)
  84
  85 (define-check-type f32vector 'f32vector
  86   ##f32vector?)
  87
  88 (define-check-type f32vector-list 'f32vector-list
  89   ##f32vector?)
  90
  91 (define-check-type f64vector 'f64vector
  92   ##f64vector?)
  93
  94 (define-check-type f64vector-list 'f64vector-list
  95   ##f64vector?)
  96
  97 (define-check-type pair-mutable 'mutable
  98   ##pair-mutable?)
  99
 100 (define-check-type subtyped-mutable 'mutable
 101   ##subtyped-mutable?)
 102
 103 (define-check-type pair 'pair
 104   ##pair?)
 105
 106 (define-check-type pair-list 'pair-list
 107   ##pair?)
 108
 109 (define-check-type list 'list
 110   ##null?)
 111
 112 (define-check-type symbol 'symbol
 113   ##symbol?)
 114
 115 (define-check-type char 'char
 116   ##char?)
 117
 118 (define-check-type char-list 'char-list
 119   ##char?)
 120
 121 (define-check-type procedure 'procedure
 122   ##procedure?)
 123
 124 (define-check-type keyword 'keyword
 125   ##keyword?)
 126
 127 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 128 (##define-macro (macro-fail-check-list arg-num form)
 129
 130   (define (rest-param x)
 131     (if (pair? x)
 132         (rest-param (cdr x))
 133         x))
 134
 135   (define (nonrest-params x)
 136     (if (pair? x)
 137       (cons (car x) (nonrest-params (cdr x)))
 138       '()))
 139
 140   (define (key-params x)
 141     (if (pair? x)
 142       (if (keyword? (car x))
 143         (cons (car x) (cons (cadr x) (key-params (cddr x))))
 144         (key-params (cdr x)))
 145       '()))
 146
 147   (define (prekey-params x)
 148     (if (or (not (pair? x)) (keyword? (car x)))
 149       '()
 150       (cons (car x) (prekey-params (cdr x)))))
 151
 152   (define (failure name)
 153     (let* ((k (key-params (cdr form)))
 154            (r (rest-param (cdr form)))
 155            (nr (nonrest-params (cdr form)))
 156            (pk (prekey-params nr)))
 157       (if (and (null? k) (not (null? r)))
 158         `(,name ,arg-num '() ,(car form) ,@pk ,r)
 159         `(,name
 160           ,arg-num
 161           ,(if (and (null? k) (null? r))
 162              (car form)
 163              `(##list ,(car form) ,@k ,@(if (null? r) '() (list r))))
 164           ,@pk))))
 165
 166   (failure '##fail-check-list))
 167
 168 ;;;============================================================================