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 : num-to-charlist ( num -- charlist )
  68     ?dup 0= if
  69         [char] 0 character-type nil cons
  70         exit
  71     then
  72
  73     nil rot
  74
  75     begin
  76         ?dup 0>
  77     while
  78         dup 10 mod swap 10 / swap
  79         2swap rot
  80         [char] 0 + character-type 2swap
  81         cons
  82         rot
  83     repeat
  84 ;
  85
  86 :noname ( args -- string )
  87     2dup 1 ensure-arg-count
  88     car fixnum-type ensure-arg-type
  89
  90     drop
  91
  92     dup 0< swap abs ( bool num )
  93     num-to-charlist
  94     rot if
  95         [char] - character-type 2swap cons
  96     then
  97
  98     drop string-type
  99 ; make-primitive number->string
 100
 101 :noname ( args -- symbol )
 102     2dup 1 ensure-arg-count
 103     car string-type ensure-arg-type
 104
 105     drop pair-type
 106
 107     2dup car [char] - character-type objeq? if
 108         cdr
 109         true -rot
 110     else
 111         2dup car [char] + character-type objeq? if
 112             cdr
 113         then
 114         false -rot
 115     then
 116
 117     0 -rot
 118     begin
 119         2dup nil objeq? false =
 120     while
 121         2dup car drop [char] 0 - -rot
 122         2swap swap 10 * + -rot
 123         cdr
 124     repeat
 125
 126     2drop
 127
 128     swap if -1 * then
 129
 130     fixnum-type
 131 ; make-primitive string->number
 132
 133 :noname ( args -- string )
 134     2dup 1 ensure-arg-count
 135     car symbol-type ensure-arg-type
 136
 137     drop pair-type
 138     duplicate-charlist
 139     drop string-type
 140 ; make-primitive symbol->string
 141
 142 :noname ( args -- symbol )
 143     2dup 1 ensure-arg-count
 144     car string-type ensure-arg-type
 145
 146     drop pair-type
 147     duplicate-charlist
 148     charlist>symbol
 149 ; make-primitive string->symbol
 150
 151 ( = Arithmetic = )
 152
 153 : add-prim ( args -- fixnum )
 154     2dup nil objeq? if
 155         2drop
 156         0 fixnum-type
 157     else
 158         2dup car drop
 159         -rot cdr recurse drop
 160         + fixnum-type
 161     then
 162 ;
 163 ' add-prim make-primitive +
 164
 165 :noname ( args -- fixnum )
 166     2dup nil objeq? if
 167         2drop
 168         0 fixnum-type
 169     else
 170         2dup car drop
 171         -rot cdr
 172         2dup nil objeq? if
 173             2drop negate
 174         else
 175             add-prim drop
 176             -
 177         then
 178         fixnum-type
 179     then
 180 ; make-primitive -
 181
 182 :noname ( args -- fixnum )
 183     2dup nil objeq? if
 184         2drop
 185         1 fixnum-type
 186     else
 187         2dup car drop
 188         -rot cdr recurse drop
 189         * fixnum-type
 190     then
 191 ; make-primitive *
 192
 193 :noname ( args -- fixnum )
 194     2dup 2 ensure-arg-count
 195
 196     2dup car fixnum-type ensure-arg-type
 197     2swap cdr car fixnum-type ensure-arg-type
 198
 199     drop swap drop
 200
 201     / fixnum-type
 202 ; make-primitive quotient
 203
 204 :noname ( args -- fixnum )
 205     2dup 2 ensure-arg-count
 206
 207     2dup car fixnum-type ensure-arg-type
 208     2swap cdr car fixnum-type ensure-arg-type
 209
 210     drop swap drop
 211
 212     mod fixnum-type
 213 ; make-primitive remainder
 214
 215 variable relcfa
 216
 217 : test-relation ( args -- bool )
 218
 219     2dup nil objeq? if
 220         2drop
 221         true boolean-type exit
 222     then
 223
 224     ( args )
 225
 226     2dup car fixnum-type ensure-arg-type ( args arg0 )
 227     2swap cdr ( arg0 args' )
 228
 229     2dup nil objeq? if
 230         2drop 2drop
 231         true boolean-type exit
 232     then
 233
 234     ( arg0 args' )
 235
 236     begin
 237         2dup nil objeq? false =
 238     while
 239         2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 )
 240         2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 )
 241         relcfa @ execute false = if
 242             2drop 2drop
 243             false boolean-type exit
 244         then
 245
 246         2swap cdr ( arg0 args'' )
 247     repeat
 248
 249     2drop 2drop
 250     true boolean-type
 251 ;
 252
 253 : fixnum-lt ( obj1 obj2 -- bool )
 254     drop swap drop <
 255 ;
 256
 257 :noname
 258     ['] fixnum-lt relcfa !
 259     test-relation
 260 ; make-primitive <
 261
 262 : fixnum-gt ( obj1 obj2 -- bool )
 263     drop swap drop >
 264 ;
 265
 266 :noname
 267     ['] fixnum-gt relcfa !
 268     test-relation
 269 ; make-primitive >
 270
 271 : fixnum-eq ( obj1 obj2 -- bool )
 272     drop swap drop =
 273 ;
 274
 275 :noname
 276     ['] fixnum-eq relcfa !
 277     test-relation
 278 ; make-primitive =
 279
 280 hide relcfa
 281
 282 ( = Pairs and Lists = )
 283
 284 :noname ( args -- pair )
 285     2dup 2 ensure-arg-count
 286
 287     2dup car 2swap cdr car
 288     cons
 289 ; make-primitive cons
 290
 291 :noname ( args -- list )
 292     \ args is already a list!
 293 ; make-primitive list
 294
 295 :noname ( args -- pair )
 296     2dup 1 ensure-arg-count
 297     car pair-type ensure-arg-type
 298
 299     car
 300 ; make-primitive car
 301
 302 :noname ( args -- pair )
 303     2dup 1 ensure-arg-count
 304     car pair-type ensure-arg-type
 305
 306     cdr
 307 ; make-primitive cdr
 308
 309 :noname ( args -- pair )
 310     2dup 2 ensure-arg-count
 311     2dup cdr car
 312     2swap car pair-type ensure-arg-type
 313
 314     set-car!
 315
 316     ok-symbol
 317 ; make-primitive set-car!
 318
 319 :noname ( args -- pair )
 320     2dup 2 ensure-arg-count
 321     2dup cdr car
 322     2swap car pair-type ensure-arg-type
 323
 324     set-cdr!
 325
 326     ok-symbol
 327 ; make-primitive set-cdr!
 328
 329 ( = Polymorphic equality testing = )
 330
 331 :noname ( args -- bool )
 332     2dup 2 ensure-arg-count
 333     2dup cdr car
 334     2swap car
 335
 336     objeq? boolean-type
 337 ; make-primitive eq?