src/scheme-primitives.4th

   1 \ ==== Type predilcates ==== {{{
   2
   3 :noname ( args -- boolobj )
   4     nil objeq? boolean-type
   5 ; 1 make-fa-primitive null?
   6
   7 :noname ( args -- boolobj )
   8     boolean-type istype? -rot 2drop boolean-type
   9 ; 1 make-fa-primitive boolean?
  10
  11 :noname ( args -- boolobj )
  12     symbol-type istype? -rot 2drop boolean-type
  13 ; 1 make-fa-primitive symbol?
  14
  15 :noname ( args -- boolobj )
  16     fixnum-type istype? -rot 2drop boolean-type
  17 ; 1 make-fa-primitive fixnum?
  18
  19 :noname ( args -- boolobj )
  20     flonum-type istype? -rot 2drop boolean-type
  21 ; 1 make-fa-primitive flonum?
  22
  23 :noname ( args -- boolobj )
  24     ratnum-type istype? -rot 2drop boolean-type
  25 ; 1 make-fa-primitive ratnum?
  26
  27 :noname ( args -- boolobj )
  28     character-type istype? -rot 2drop boolean-type
  29 ; 1 make-fa-primitive char?
  30
  31 :noname ( args -- boolobj )
  32     string-type istype? -rot 2drop boolean-type
  33 ; 1 make-fa-primitive string?
  34
  35 :noname ( args -- boolobj )
  36     pair-type istype? -rot 2drop boolean-type
  37 ; 1 make-fa-primitive pair?
  38
  39 :noname ( args -- boolobj )
  40     primitive-proc-type istype? if
  41         true
  42     else
  43         compound-proc-type istype?
  44     then
  45
  46     -rot 2drop boolean-type
  47 ; 1 make-fa-primitive procedure?
  48
  49 :noname ( args -- boolobj )
  50     port-type istype? -rot 2drop boolean-type
  51 ; 1 make-fa-primitive port?
  52
  53 \ }}}
  54
  55 \ ==== Type conversions ==== {{{
  56
  57 :noname ( args -- fixnum )
  58     2dup 1 ensure-arg-count
  59     car character-type ensure-arg-type
  60
  61     drop fixnum-type
  62 ; make-primitive char->integer
  63
  64 :noname ( args -- char )
  65     2dup 1 ensure-arg-count
  66     car fixnum-type ensure-arg-type
  67
  68     drop character-type
  69 ; make-primitive integer->char
  70
  71 : fixnum-to-charlist ( fixnum -- charlist )
  72     over 0= if
  73         2drop
  74         [char] 0 character-type nil cons
  75         exit
  76     then
  77
  78     nil 2swap ( charlist fixnum )
  79
  80     begin
  81         over 0>
  82     while
  83         2dup swap 10 mod swap ( charlist fixnum fixnummod )
  84         2swap swap 10 / swap  ( charlist fixnummod fixnumdiv )
  85         -2rot ( fixnumdiv charlist fixnummod )
  86
  87         drop [char] 0 + character-type 2swap
  88         cons ( fixnumdiv newcharlist )
  89
  90         2swap
  91     repeat
  92
  93     2drop
  94 ;
  95
  96 :noname ( args -- string )
  97     2dup 1 ensure-arg-count
  98     car fixnum-type ensure-arg-type
  99
 100     2dup swap abs swap
 101
 102     fixnum-to-charlist ( fixnum charlist )
 103     2swap drop 0< if
 104         [char] - character-type 2swap cons
 105     then
 106
 107     drop string-type
 108 ; make-primitive number->string
 109
 110 :noname ( args -- symbol )
 111     2dup 1 ensure-arg-count
 112     car string-type ensure-arg-type
 113
 114     drop pair-type
 115
 116     2dup car [char] - character-type objeq? if
 117         cdr
 118         true -rot
 119     else
 120         2dup car [char] + character-type objeq? if
 121             cdr
 122         then
 123         false -rot
 124     then
 125
 126     0 -rot
 127     begin
 128         2dup nil objeq? false =
 129     while
 130         2dup car drop [char] 0 - -rot
 131         2swap swap 10 * + -rot
 132         cdr
 133     repeat
 134
 135     2drop
 136
 137     swap if -1 * then
 138
 139     fixnum-type
 140 ; make-primitive string->number
 141
 142 :noname ( args -- string )
 143     2dup 1 ensure-arg-count
 144     car symbol-type ensure-arg-type
 145
 146     drop pair-type
 147     duplicate-charlist
 148     drop string-type
 149 ; make-primitive symbol->string
 150
 151 :noname ( args -- symbol )
 152     2dup 1 ensure-arg-count
 153     car string-type ensure-arg-type
 154
 155     drop pair-type
 156     duplicate-charlist
 157     charlist>symbol
 158 ; make-primitive string->symbol
 159
 160 :noname ( charlist -- string )
 161     2dup 1 ensure-arg-count
 162
 163     car nil? if
 164         2drop
 165         nil nil cons
 166         drop string-type
 167         exit
 168     then
 169
 170     pair-type ensure-arg-type
 171
 172     duplicate-charlist
 173     drop string-type
 174 ; make-primitive list->string
 175
 176 :noname ( string -- charlist )
 177     2dup 1 ensure-arg-count
 178     car string-type ensure-arg-type
 179
 180     drop pair-type
 181
 182     2dup car nil? if
 183         2swap 2drop
 184     else
 185         2drop
 186         duplicate-charlist
 187     then
 188
 189 ; make-primitive string->list
 190
 191 \ }}}
 192
 193 \ ==== Numeric types ==== {{{
 194
 195 \ --- Fixnums ---
 196
 197 :noname ( fixnum fixnum -- boolobj )
 198     objeq? boolean-type
 199 ; 2 make-fa-primitive fix:=
 200
 201 :noname ( fixnum fixnum -- boolobj )
 202     drop swap drop < boolean-type
 203 ; 2 make-fa-primitive fix:<
 204
 205 :noname ( fixnum fixnum -- boolobj )
 206     drop swap drop > boolean-type
 207 ; 2 make-fa-primitive fix:>
 208
 209 :noname ( fixnum fixnum -- boolobj )
 210     drop swap drop <= boolean-type
 211 ; 2 make-fa-primitive fix:<=
 212
 213 :noname ( fixnum fixnum -- boolobj )
 214     drop swap drop >= boolean-type
 215 ; 2 make-fa-primitive fix:>=
 216
 217 :noname ( fixnum -- boolobj )
 218     drop 0= boolean-type
 219 ; 1 make-fa-primitive fix:zero?
 220
 221 :noname ( fixnum -- boolobj )
 222     drop 0> boolean-type
 223 ; 1 make-fa-primitive fix:positive?
 224
 225 :noname ( fixnum -- boolobj )
 226     drop 0< boolean-type
 227 ; 1 make-fa-primitive fix:negative?
 228
 229 :noname ( fixnum fixnum -- fixnum' )
 230     drop swap drop + fixnum-type
 231 ; 2 make-fa-primitive fix:+
 232
 233 :noname ( fixnum fixnum -- fixnum' )
 234     drop swap drop - fixnum-type
 235 ; 2 make-fa-primitive fix:-
 236
 237 :noname ( fixnum fixnum -- fixnum' )
 238     drop swap drop * fixnum-type
 239 ; 2 make-fa-primitive fix:*
 240
 241 :noname ( fixnum fixnum -- fixnum' )
 242     drop swap drop / fixnum-type
 243 ; 2 make-fa-primitive fix:quotient
 244
 245 :noname ( fixnum fixnum -- fixnum' )
 246     drop swap drop mod fixnum-type
 247 ; 2 make-fa-primitive fix:remainder
 248
 249 :noname ( fixnum -- fixnum+1 )
 250     swap 1+ swap
 251 ; 1 make-fa-primitive fix:1+
 252
 253 :noname ( fixnum -- fixnum-1 )
 254     swap 1- swap
 255 ; 1 make-fa-primitive fix:-1+
 256
 257 :noname ( fixnum -- -fixnum )
 258     swap negate swap
 259 ; 1 make-fa-primitive fix:neg
 260
 261 :noname ( fixnum -- -fixnum )
 262     swap abs swap
 263 ; 1 make-fa-primitive fix:abs
 264
 265 :noname ( fixnum fixnum -- fixnum' )
 266     drop swap drop gcd fixnum-type
 267 ; 2 make-fa-primitive fix:gcd
 268
 269 \ --- Flonums ---
 270
 271 :noname ( flonum flonum -- bool )
 272     objeq? boolean-type
 273 ; 2 make-fa-primitive flo:=
 274
 275 :noname ( flonum flonum -- bool )
 276     drop swap drop f< boolean-type
 277 ; 2 make-fa-primitive flo:<
 278
 279 :noname ( flonum flonum -- bool )
 280     drop swap drop f> boolean-type
 281 ; 2 make-fa-primitive flo:>
 282
 283
 284 :noname ( flonum -- bool )
 285     drop 0.0 = boolean-type
 286 ; 1 make-fa-primitive flo:zero?
 287
 288 :noname ( flonum -- bool )
 289     drop 0.0 f> boolean-type
 290 ; 1 make-fa-primitive flo:positive?
 291
 292 :noname ( flonum -- bool )
 293     drop 0.0 f< boolean-type
 294 ; 1 make-fa-primitive flo:negative?
 295
 296
 297 :noname ( flonum1 flonum2 -- flonum1+flonum2 )
 298     drop swap drop f+ flonum-type
 299 ; 2 make-fa-primitive flo:+
 300
 301 :noname ( flonum1 flonum2 -- flonum1-flonum2 )
 302     drop swap drop f- flonum-type
 303 ; 2 make-fa-primitive flo:-
 304
 305 :noname ( flonum1 flonum2 -- flonum1*flonum2 )
 306     drop swap drop f* flonum-type
 307 ; 2 make-fa-primitive flo:*
 308
 309 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 310     drop swap drop f/ flonum-type
 311 ; 2 make-fa-primitive flo:/
 312
 313 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 314     drop swap drop f/ flonum-type
 315 ; 2 make-fa-primitive flo:/
 316
 317
 318 :noname ( flonum -- bool )
 319     drop dup
 320     fnan? swap finf? or invert
 321 ; 1 make-fa-primitive flo:finite?
 322
 323
 324 :noname ( flonum -- flonum )
 325     swap -1.0 f* swap
 326 ; 1 make-fa-primitive flo:neg
 327
 328 :noname ( flonum -- flonum )
 329     swap fabs swap
 330 ; 1 make-fa-primitive flo:abs
 331
 332 :noname ( flonum -- flonum )
 333     swap fexp swap
 334 ; 1 make-fa-primitive flo:exp
 335
 336 :noname ( flonum -- flonum )
 337     swap flog swap
 338 ; 1 make-fa-primitive flo:log
 339
 340 :noname ( flonum -- flonum )
 341     swap fsin swap
 342 ; 1 make-fa-primitive flo:sin
 343
 344 :noname ( flonum -- flonum )
 345     swap fcos swap
 346 ; 1 make-fa-primitive flo:cos
 347
 348 :noname ( flonum -- flonum )
 349     swap ftan swap
 350 ; 1 make-fa-primitive flo:tan
 351
 352 :noname ( flonum -- flonum )
 353     swap fasin swap
 354 ; 1 make-fa-primitive flo:asin
 355
 356 :noname ( flonum -- flonum )
 357     swap facos swap
 358 ; 1 make-fa-primitive flo:acos
 359
 360 :noname ( flonum -- flonum )
 361     swap fatan swap
 362 ; 1 make-fa-primitive flo:atan
 363
 364 :noname ( flonum -- flonum )
 365     swap fsqrt swap
 366 ; 1 make-fa-primitive flo:sqrt
 367
 368 :noname ( flonum flonum -- flonum )
 369     drop swap drop f^ flonum-type
 370 ; 2 make-fa-primitive flo:expt
 371
 372 :noname ( flonum -- flonum )
 373     swap floor swap
 374 ; 1 make-fa-primitive flo:floor
 375
 376 :noname ( flonum -- flonum )
 377     swap ceiling swap
 378 ; 1 make-fa-primitive flo:ceiling
 379
 380 :noname ( flonum -- flonum )
 381     swap truncate swap
 382 ; 1 make-fa-primitive flo:truncate
 383
 384 :noname ( flonum -- flonum )
 385     swap fround swap
 386 ; 1 make-fa-primitive flo:round
 387
 388 :noname ( flonum -- flonum )
 389     drop floor f->i fixnum-type
 390 ; 1 make-fa-primitive flo:floor->exact
 391
 392 :noname ( flonum -- flonum )
 393     drop ceiling f->i fixnum-type
 394 ; 1 make-fa-primitive flo:ceiling->exact
 395
 396 :noname ( flonum -- flonum )
 397     drop truncate f->i fixnum-type
 398 ; 1 make-fa-primitive flo:truncate->exact
 399
 400 :noname ( flonum -- flonum )
 401     drop f->i fixnum-type
 402 ; 1 make-fa-primitive flo:round->exact
 403
 404 :noname ( flonum flonum -- flonum )
 405     drop swap drop f/ fatan flonum-type
 406 ; 2 make-fa-primitive flo:atan2
 407
 408 \ --- Rationals ---
 409
 410 ' make-rational 2 make-fa-primitive make-rational
 411
 412 :noname ( ratnum -- fixnum )
 413     drop pair-type car
 414 ; 1 make-fa-primitive rat:numerator
 415
 416 :noname ( ratnum -- fixnum )
 417     drop pair-type cdr
 418 ; 1 make-fa-primitive rat:denominator
 419
 420 \ --- Conversion ---
 421
 422 :noname ( fixnum -- flonum )
 423     drop i->f flonum-type
 424 ; 1 make-fa-primitive fixnum->flonum
 425
 426 \ }}}
 427
 428 \ ==== Pairs and Lists ==== {{{
 429
 430 :noname ( arg1 arg2 -- pair )
 431     cons
 432 ; 2 make-fa-primitive cons
 433
 434 :noname ( pair-obj -- obj )
 435     car
 436 ; pair-type 1 make-fa-type-primitive car
 437
 438 :noname ( args -- obj )
 439     cdr
 440 ; pair-type 1 make-fa-type-primitive cdr
 441
 442 :noname ( pair obj  -- ok )
 443     2swap pair-type ensure-arg-type
 444
 445     set-car!
 446
 447     ok-symbol
 448 ; 2 make-fa-primitive set-car!
 449
 450 :noname ( pair obj -- ok )
 451     2swap pair-type ensure-arg-type
 452
 453     set-cdr!
 454
 455     ok-symbol
 456 ; 2 make-fa-primitive set-cdr!
 457
 458 \ }}}
 459
 460 \ ==== Polymorphic equality testing ==== {{{
 461
 462 :noname ( arg1 arg2 -- bool )
 463     objeq? boolean-type
 464 ; 2 make-fa-primitive eq?
 465
 466 \ }}}
 467
 468 \ ==== Input/Output ==== {{{
 469
 470 :noname ( -- port )
 471     console-i/o-port obj@
 472 ; 0 make-fa-primitive console-i/o-port
 473
 474 :noname ( -- port )
 475     current-input-port obj@
 476 ; 0 make-fa-primitive current-input-port
 477
 478 :noname ( args -- charobj )
 479     nil? if
 480         2drop current-input-port obj@
 481     else
 482         car port-type ensure-arg-type
 483     then
 484
 485     read-char
 486 ; make-primitive read-char
 487
 488 :noname ( args -- charobj )
 489     nil? if
 490         2drop current-input-port obj@
 491     else
 492         car port-type ensure-arg-type
 493     then
 494
 495     peek-char
 496 ; make-primitive peek-char
 497
 498 :noname ( args -- stringobj )
 499     nil? if
 500         2drop current-input-port obj@
 501     else
 502         car port-type ensure-arg-type
 503     then
 504
 505     read-line
 506 ; make-primitive read-line
 507
 508 : charlist>cstr ( charlist addr -- n )
 509
 510     dup 2swap ( origaddr addr charlist )
 511
 512     begin
 513         nil? false =
 514     while
 515         2dup cdr 2swap car
 516         drop ( origaddr addr charlist char )
 517         -rot 2swap ( origaddr charlist addr char )
 518         over !
 519         1+ -rot ( origaddr nextaddr charlist )
 520     repeat
 521
 522     2drop ( origaddr finaladdr )
 523     swap -
 524 ;
 525
 526 :noname ( args -- finalResult )
 527     drop pair-type
 528     pad charlist>cstr
 529     pad swap load
 530 ; string-type 1 make-fa-type-primitive load
 531
 532 :noname ( args -- obj )
 533     read
 534 ; 0 make-fa-primitive read
 535
 536 defer display
 537
 538 :noname ( obj -- none )
 539     print none
 540 ; 1 make-fa-primitive write
 541
 542 : displaypair ( pairobj -- )
 543     2dup
 544     car display
 545     cdr
 546     nil? if 2drop exit then
 547     pair-type istype? if space recurse exit then
 548     ."  . " display
 549 ;
 550
 551 : displaychar ( charobj -- )
 552     drop emit ;
 553
 554 : (displaystring) ( charlist -- )
 555     nil? if
 556         2drop
 557     else
 558         2dup car displaychar
 559         cdr recurse
 560     then
 561 ;
 562
 563 : displaystring ( stringobj -- )
 564     drop pair-type (displaystring)
 565 ;
 566
 567 :noname ( obj -- )
 568     pair-type istype? if ." (" displaypair ." )" exit then
 569     character-type istype? if displaychar exit then
 570     string-type istype? if displaystring exit then
 571
 572     print
 573 ; is display
 574
 575 :noname ( stringobj -- none )
 576     displaystring none
 577 ; string-type 1 make-fa-type-primitive display-string
 578
 579 :noname ( charobj -- none )
 580     displaychar none
 581 ; character-type 1 make-fa-type-primitive display-character
 582
 583 :noname ( obj -- none )
 584     display none
 585 ; 1 make-fa-primitive display
 586
 587 :noname ( args -- none )
 588     cr none
 589 ; 0 make-fa-primitive newline
 590
 591 \ }}}
 592
 593 \ ==== Evaluation ==== {{{
 594
 595 :noname ( args -- result )
 596     2dup car 2swap cdr
 597
 598     nil? false = if car then ( proc argvals )
 599
 600     apply
 601 ; make-primitive apply
 602
 603 \ }}}
 604
 605 \ ==== Miscellaneous  ==== {{{
 606
 607 ( Produce a recoverable exception. )
 608 :noname ( args -- result )
 609     bold fg red
 610
 611     nil? if
 612         ." Error."
 613     else
 614         ." Error: "
 615
 616         begin
 617             2dup car print
 618             cdr nil?
 619         until
 620
 621         2drop
 622     then
 623
 624     reset-term
 625
 626     recoverable-exception throw
 627 ; make-primitive error
 628
 629 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
 630 :noname ( args -- result )
 631     [char] _  character-type nil cons
 632     drop symbol-type
 633 ; 0 make-fa-primitive gensym
 634
 635 ( Generate the NONE object indicating an unspecified return value. )
 636 :noname ( args -- result )
 637     none
 638 ; 0 make-fa-primitive none
 639
 640 \ }}}
 641
 642 \ vim:fdm=marker