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 -- char )
  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 : build-fixnum-charlist ( num )
  68     dup 0= if
  69         nil
  70     else
  71         dup 10 / recurse
  72         rot 10 mod [char] 0 + character-type 2swap
  73         cons
  74     then
  75 ;
  76 :noname ( args -- string )
  77     2dup 1 ensure-arg-count
  78     car fixnum-type ensure-arg-type
  79
  80     drop
  81
  82     dup 0< swap abs ( bool num )
  83     build-fixnum-charlist
  84     rot drop
  85     rot if
  86         [char] - character-type 2swap cons
  87     then
  88
  89     drop string-type
  90 ; make-primitive number->string
  91
  92 ( = Arithmeic = )
  93
  94 : add-prim ( args -- fixnum )
  95     2dup nil objeq? if
  96         2drop
  97         0 fixnum-type
  98     else
  99         2dup car drop
 100         -rot cdr recurse drop
 101         + fixnum-type
 102     then
 103 ;
 104 ' add-prim make-primitive +
 105
 106 :noname ( args -- fixnum )
 107     2dup nil objeq? if
 108         2drop
 109         0 fixnum-type
 110     else
 111         2dup car drop
 112         -rot cdr add-prim drop
 113         - fixnum-type
 114     then
 115 ; make-primitive -
 116
 117 :noname ( args -- fixnum )
 118     2dup nil objeq? if
 119         2drop
 120         1 fixnum-type
 121     else
 122         2dup car drop
 123         -rot cdr recurse drop
 124         * fixnum-type
 125     then
 126 ; make-primitive *
 127