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 ( = Arithmeic = )
  52
  53 : add-prim ( args -- fixnum )
  54     2dup nil objeq? if
  55         2drop
  56         0 fixnum-type
  57     else
  58         2dup car drop
  59         -rot cdr recurse drop
  60         + fixnum-type
  61     then
  62 ;
  63 ' add-prim make-primitive +
  64
  65 :noname ( args -- fixnum )
  66     2dup nil objeq? if
  67         2drop
  68         0 fixnum-type
  69     else
  70         2dup car drop
  71         -rot cdr add-prim drop
  72         - fixnum-type
  73     then
  74 ; make-primitive -
  75
  76 :noname ( args -- fixnum )
  77     2dup nil objeq? if
  78         2drop
  79         1 fixnum-type
  80     else
  81         2dup car drop
  82         -rot cdr recurse drop
  83         * fixnum-type
  84     then
  85 ; make-primitive *
  86