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-proc-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 : fixnum-to-charlist ( fixnum -- charlist )
  68     over 0= if
  69         2drop
  70         [char] 0 character-type nil cons
  71         exit
  72     then
  73
  74     nil 2swap ( charlist fixnum )
  75
  76     begin
  77         over 0>
  78     while
  79         2dup swap 10 mod swap ( charlist fixnum fixnummod )
  80         2swap swap 10 / swap  ( charlist fixnummod fixnumdiv )
  81         -2rot ( fixnumdiv charlist fixnummod )
  82
  83         drop [char] 0 + character-type 2swap
  84         cons ( fixnumdiv newcharlist )
  85
  86         2swap
  87     repeat
  88
  89     2drop
  90 ;
  91
  92 :noname ( args -- string )
  93     2dup 1 ensure-arg-count
  94     car fixnum-type ensure-arg-type
  95
  96     2dup swap abs swap
  97
  98     fixnum-to-charlist ( fixnum charlist )
  99     2swap drop 0< if
 100         [char] - character-type 2swap cons
 101     then
 102
 103     drop string-type
 104 ; make-primitive number->string
 105
 106 :noname ( args -- symbol )
 107     2dup 1 ensure-arg-count
 108     car string-type ensure-arg-type
 109
 110     drop pair-type
 111
 112     2dup car [char] - character-type objeq? if
 113         cdr
 114         true -rot
 115     else
 116         2dup car [char] + character-type objeq? if
 117             cdr
 118         then
 119         false -rot
 120     then
 121
 122     0 -rot
 123     begin
 124         2dup nil objeq? false =
 125     while
 126         2dup car drop [char] 0 - -rot
 127         2swap swap 10 * + -rot
 128         cdr
 129     repeat
 130
 131     2drop
 132
 133     swap if -1 * then
 134
 135     fixnum-type
 136 ; make-primitive string->number
 137
 138 :noname ( args -- string )
 139     2dup 1 ensure-arg-count
 140     car symbol-type ensure-arg-type
 141
 142     drop pair-type
 143     duplicate-charlist
 144     drop string-type
 145 ; make-primitive symbol->string
 146
 147 :noname ( args -- symbol )
 148     2dup 1 ensure-arg-count
 149     car string-type ensure-arg-type
 150
 151     drop pair-type
 152     duplicate-charlist
 153     charlist>symbol
 154 ; make-primitive string->symbol
 155
 156 ( ==== Arithmetic ==== )
 157
 158 : add-prim ( args -- fixnum )
 159     2dup nil objeq? if
 160         2drop
 161         0 fixnum-type
 162     else
 163         2dup car drop
 164         -rot cdr recurse drop
 165         + fixnum-type
 166     then
 167 ;
 168 ' add-prim make-primitive +
 169
 170 :noname ( args -- fixnum )
 171     2dup nil objeq? if
 172         2drop
 173         0 fixnum-type
 174     else
 175         2dup car drop
 176         -rot cdr
 177         2dup nil objeq? if
 178             2drop negate
 179         else
 180             add-prim drop
 181             -
 182         then
 183         fixnum-type
 184     then
 185 ; make-primitive -
 186
 187 :noname ( args -- fixnum )
 188     2dup nil objeq? if
 189         2drop
 190         1 fixnum-type
 191     else
 192         2dup car drop
 193         -rot cdr recurse drop
 194         * fixnum-type
 195     then
 196 ; make-primitive *
 197
 198 :noname ( args -- fixnum )
 199     2dup 2 ensure-arg-count
 200
 201     2dup car fixnum-type ensure-arg-type
 202     2swap cdr car fixnum-type ensure-arg-type
 203
 204     drop swap drop
 205
 206     / fixnum-type
 207 ; make-primitive quotient
 208
 209 :noname ( args -- fixnum )
 210     2dup 2 ensure-arg-count
 211
 212     2dup car fixnum-type ensure-arg-type
 213     2swap cdr car fixnum-type ensure-arg-type
 214
 215     drop swap drop
 216
 217     mod fixnum-type
 218 ; make-primitive remainder
 219
 220 variable relcfa
 221
 222 : test-relation ( args -- bool )
 223
 224     2dup nil objeq? if
 225         2drop
 226         true boolean-type exit
 227     then
 228
 229     ( args )
 230
 231     2dup car fixnum-type ensure-arg-type ( args arg0 )
 232     2swap cdr ( arg0 args' )
 233
 234     2dup nil objeq? if
 235         2drop 2drop
 236         true boolean-type exit
 237     then
 238
 239     ( arg0 args' )
 240
 241     begin
 242         2dup nil objeq? false =
 243     while
 244         2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 )
 245         2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 )
 246         relcfa @ execute false = if
 247             2drop 2drop
 248             false boolean-type exit
 249         then
 250
 251         2swap cdr ( arg0 args'' )
 252     repeat
 253
 254     2drop 2drop
 255     true boolean-type
 256 ;
 257
 258 : fixnum-lt ( obj1 obj2 -- bool )
 259     drop swap drop <
 260 ;
 261
 262 :noname
 263     ['] fixnum-lt relcfa !
 264     test-relation
 265 ; make-primitive <
 266
 267 : fixnum-gt ( obj1 obj2 -- bool )
 268     drop swap drop >
 269 ;
 270
 271 :noname
 272     ['] fixnum-gt relcfa !
 273     test-relation
 274 ; make-primitive >
 275
 276 : fixnum-eq ( obj1 obj2 -- bool )
 277     drop swap drop =
 278 ;
 279
 280 :noname
 281     ['] fixnum-eq relcfa !
 282     test-relation
 283 ; make-primitive =
 284
 285 hide relcfa
 286
 287 ( ==== Pairs and Lists ==== )
 288
 289 :noname ( args -- pair )
 290     2dup 2 ensure-arg-count
 291
 292     2dup car 2swap cdr car
 293     cons
 294 ; make-primitive cons
 295
 296 :noname ( args -- list )
 297     \ args is already a list!
 298 ; make-primitive list
 299
 300 :noname ( args -- pair )
 301     2dup 1 ensure-arg-count
 302     car pair-type ensure-arg-type
 303
 304     car
 305 ; make-primitive car
 306
 307 :noname ( args -- pair )
 308     2dup 1 ensure-arg-count
 309     car pair-type ensure-arg-type
 310
 311     cdr
 312 ; make-primitive cdr
 313
 314 :noname ( args -- pair )
 315     2dup 2 ensure-arg-count
 316     2dup cdr car
 317     2swap car pair-type ensure-arg-type
 318
 319     set-car!
 320
 321     ok-symbol
 322 ; make-primitive set-car!
 323
 324 :noname ( args -- pair )
 325     2dup 2 ensure-arg-count
 326     2dup cdr car
 327     2swap car pair-type ensure-arg-type
 328
 329     set-cdr!
 330
 331     ok-symbol
 332 ; make-primitive set-cdr!
 333
 334 ( ==== Polymorphic equality testing ==== )
 335
 336 :noname ( args -- bool )
 337     2dup 2 ensure-arg-count
 338     2dup cdr car
 339     2swap car
 340
 341     objeq? boolean-type
 342 ; make-primitive eq?
 343
 344 ( ==== Input/Output ==== )
 345
 346 :noname ( args -- finalResult )
 347     2dup 1 ensure-arg-count
 348     car string-type ensure-arg-type
 349
 350     drop pair-type
 351     pad charlist>cstr
 352     pad swap load
 353 ; make-primitive load
 354
 355 ' read make-primitive read
 356
 357 defer display
 358 :noname ( args -- none )
 359     2dup 1 ensure-arg-count
 360
 361     car print
 362
 363     none
 364 ; make-primitive write
 365
 366 : displaypair ( pairobj -- )
 367     2dup
 368     car display
 369     cdr
 370     nil? if 2drop exit then
 371     pair-type istype? if space recurse exit then
 372     ."  . " display
 373 ;
 374
 375 : displaychar ( charobj -- )
 376     drop emit ;
 377
 378 : (displaystring) ( charlist -- )
 379     nil? if
 380         2drop
 381     else
 382         2dup car displaychar
 383         cdr recurse
 384     then
 385 ;
 386
 387 : displaystring ( stringobj -- )
 388     drop pair-type (displaystring)
 389 ;
 390
 391 :noname ( obj -- )
 392     pair-type istype? if ." (" displaypair ." )" exit then
 393     character-type istype? if displaychar exit then
 394     string-type istype? if displaystring exit then
 395
 396     print
 397 ; is display
 398
 399 :noname ( args -- none )
 400     2dup 1 ensure-arg-count
 401     car string-type ensure-arg-type
 402
 403     displaystring
 404
 405     none
 406 ; make-primitive display-string
 407
 408 :noname ( args -- none )
 409     2dup 1 ensure-arg-count
 410     car character-type ensure-arg-type
 411
 412     displaychar
 413
 414     none
 415 ; make-primitive display-character
 416
 417 :noname ( args -- none )
 418     2dup 1 ensure-arg-count
 419     car
 420
 421     display
 422
 423     none
 424 ; make-primitive display
 425
 426 :noname ( args -- none )
 427     0 ensure-arg-count
 428
 429     cr
 430
 431     none
 432 ; make-primitive newline
 433
 434 ( ==== Evaluation ==== )
 435
 436 :noname ( args -- result )
 437     2dup car 2swap cdr
 438
 439     nil? false = if car then ( proc argvals )
 440
 441     apply
 442 ; make-primitive apply
 443
 444 ( ==== Error System ==== )
 445
 446 :noname ( args -- result )
 447     bold fg red
 448
 449     nil? if
 450         ." Error."
 451     else
 452         ." Error: " car display
 453     then
 454
 455     reset-term
 456
 457     recoverable-exception throw
 458 ; make-primitive error