scheme-primitives.4th

   1 ( = Type predicates = )
   2
   3 :noname ( args -- boolobj )
   4     2dup 1 ensure-arg-count
   5
   6     car nil objeq? boolean-type
   7 ; make-primitive null?
   8
   9 :noname ( args -- boolobj )
  10     2dup 1 ensure-arg-count
  11
  12     car boolean-type istype? -rot 2drop boolean-type
  13 ; make-primitive boolean?
  14
  15 :noname ( args -- boolobj )
  16     2dup 1 ensure-arg-count
  17
  18     car symbol-type istype? -rot 2drop boolean-type
  19 ; make-primitive symbol?
  20
  21 :noname ( args -- boolobj )
  22     2dup 1 ensure-arg-count
  23
  24     car fixnum-type istype? -rot 2drop boolean-type
  25 ; make-primitive integer?
  26
  27 :noname ( args -- boolobj )
  28     2dup 1 ensure-arg-count
  29
  30     car character-type istype? -rot 2drop boolean-type
  31 ; make-primitive char?
  32
  33 :noname ( args -- boolobj )
  34     2dup 1 ensure-arg-count
  35
  36     car string-type istype? -rot 2drop boolean-type
  37 ; make-primitive string?
  38
  39 :noname ( args -- boolobj )
  40     2dup 1 ensure-arg-count
  41
  42     car pair-type istype? -rot 2drop boolean-type
  43 ; make-primitive pair?
  44
  45 :noname ( args -- boolobj )
  46     2dup 1 ensure-arg-count
  47
  48     car primitive-type istype? -rot 2drop boolean-type
  49 ; make-primitive procedure?
  50
  51 ( = Type conversions = )
  52
  53 :noname ( args -- fixnum )
  54     2dup 1 ensure-arg-count
  55     car character-type ensure-arg-type
  56
  57     drop fixnum-type
  58 ; make-primitive char->integer
  59
  60 :noname ( args -- fixnum )
  61     2dup 1 ensure-arg-count
  62     car fixnum-type ensure-arg-type
  63
  64     drop character-type
  65 ; make-primitive integer->char
  66
  67 ( = Arithmeic = )
  68
  69 : add-prim ( args -- fixnum )
  70     2dup nil objeq? if
  71         2drop
  72         0 fixnum-type
  73     else
  74         2dup car drop
  75         -rot cdr recurse drop
  76         + fixnum-type
  77     then
  78 ;
  79 ' add-prim make-primitive +
  80
  81 :noname ( args -- fixnum )
  82     2dup nil objeq? if
  83         2drop
  84         0 fixnum-type
  85     else
  86         2dup car drop
  87         -rot cdr add-prim drop
  88         - fixnum-type
  89     then
  90 ; make-primitive -
  91
  92 :noname ( args -- fixnum )
  93     2dup nil objeq? if
  94         2drop
  95         1 fixnum-type
  96     else
  97         2dup car drop
  98         -rot cdr recurse drop
  99         * fixnum-type
 100     then
 101 ; make-primitive *
 102