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 :noname ( flonum flonum -- bool )
 284     drop swap drop f<= boolean-type
 285 ; 2 make-fa-primitive flo:<=
 286
 287 :noname ( flonum flonum -- bool )
 288     drop swap drop f>= boolean-type
 289 ; 2 make-fa-primitive flo:>=
 290
 291 :noname ( flonum -- bool )
 292     drop 0.0 = boolean-type
 293 ; 1 make-fa-primitive flo:zero?
 294
 295 :noname ( flonum -- bool )
 296     drop 0.0 f> boolean-type
 297 ; 1 make-fa-primitive flo:positive?
 298
 299 :noname ( flonum -- bool )
 300     drop 0.0 f< boolean-type
 301 ; 1 make-fa-primitive flo:negative?
 302
 303
 304 :noname ( flonum1 flonum2 -- flonum1+flonum2 )
 305     drop swap drop f+ flonum-type
 306 ; 2 make-fa-primitive flo:+
 307
 308 :noname ( flonum1 flonum2 -- flonum1-flonum2 )
 309     drop swap drop f- flonum-type
 310 ; 2 make-fa-primitive flo:-
 311
 312 :noname ( flonum1 flonum2 -- flonum1*flonum2 )
 313     drop swap drop f* flonum-type
 314 ; 2 make-fa-primitive flo:*
 315
 316 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 317     drop swap drop f/ flonum-type
 318 ; 2 make-fa-primitive flo:/
 319
 320 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 321     drop swap drop f/ flonum-type
 322 ; 2 make-fa-primitive flo:/
 323
 324
 325 :noname ( flonum -- bool )
 326     drop dup
 327     fnan? swap finf? or invert
 328 ; 1 make-fa-primitive flo:finite?
 329
 330
 331 :noname ( flonum -- flonum )
 332     swap -1.0 f* swap
 333 ; 1 make-fa-primitive flo:neg
 334
 335 :noname ( flonum -- flonum )
 336     swap fabs swap
 337 ; 1 make-fa-primitive flo:abs
 338
 339 :noname ( flonum -- flonum )
 340     swap fexp swap
 341 ; 1 make-fa-primitive flo:exp
 342
 343 :noname ( flonum -- flonum )
 344     swap flog swap
 345 ; 1 make-fa-primitive flo:log
 346
 347 :noname ( flonum -- flonum )
 348     swap fsin swap
 349 ; 1 make-fa-primitive flo:sin
 350
 351 :noname ( flonum -- flonum )
 352     swap fcos swap
 353 ; 1 make-fa-primitive flo:cos
 354
 355 :noname ( flonum -- flonum )
 356     swap ftan swap
 357 ; 1 make-fa-primitive flo:tan
 358
 359 :noname ( flonum -- flonum )
 360     swap fasin swap
 361 ; 1 make-fa-primitive flo:asin
 362
 363 :noname ( flonum -- flonum )
 364     swap facos swap
 365 ; 1 make-fa-primitive flo:acos
 366
 367 :noname ( flonum -- flonum )
 368     swap fatan swap
 369 ; 1 make-fa-primitive flo:atan
 370
 371 :noname ( flonum -- flonum )
 372     swap fsqrt swap
 373 ; 1 make-fa-primitive flo:sqrt
 374
 375 :noname ( flonum flonum -- flonum )
 376     drop swap drop f^ flonum-type
 377 ; 2 make-fa-primitive flo:expt
 378
 379 :noname ( flonum -- flonum )
 380     swap floor swap
 381 ; 1 make-fa-primitive flo:floor
 382
 383 :noname ( flonum -- flonum )
 384     swap ceiling swap
 385 ; 1 make-fa-primitive flo:ceiling
 386
 387 :noname ( flonum -- flonum )
 388     swap truncate swap
 389 ; 1 make-fa-primitive flo:truncate
 390
 391 :noname ( flonum -- flonum )
 392     swap fround swap
 393 ; 1 make-fa-primitive flo:round
 394
 395 :noname ( flonum -- flonum )
 396     drop floor f->i fixnum-type
 397 ; 1 make-fa-primitive flo:floor->exact
 398
 399 :noname ( flonum -- flonum )
 400     drop ceiling f->i fixnum-type
 401 ; 1 make-fa-primitive flo:ceiling->exact
 402
 403 :noname ( flonum -- flonum )
 404     drop truncate f->i fixnum-type
 405 ; 1 make-fa-primitive flo:truncate->exact
 406
 407 :noname ( flonum -- flonum )
 408     drop f->i fixnum-type
 409 ; 1 make-fa-primitive flo:round->exact
 410
 411 :noname ( flonum flonum -- flonum )
 412     drop swap drop f/ fatan flonum-type
 413 ; 2 make-fa-primitive flo:atan2
 414
 415 \ --- Rationals ---
 416
 417 ' make-rational 2 make-fa-primitive make-rational
 418
 419 :noname ( ratnum -- fixnum )
 420     drop pair-type car
 421 ; 1 make-fa-primitive rat:numerator
 422
 423 :noname ( ratnum -- fixnum )
 424     drop pair-type cdr
 425 ; 1 make-fa-primitive rat:denominator
 426
 427 \ --- Conversion ---
 428
 429 :noname ( fixnum -- flonum )
 430     drop i->f flonum-type
 431 ; 1 make-fa-primitive fixnum->flonum
 432
 433 \ }}}
 434
 435 \ ==== Pairs and Lists ==== {{{
 436
 437 :noname ( arg1 arg2 -- pair )
 438     cons
 439 ; 2 make-fa-primitive cons
 440
 441 :noname ( pair-obj -- obj )
 442     car
 443 ; pair-type 1 make-fa-type-primitive car
 444
 445 :noname ( args -- obj )
 446     cdr
 447 ; pair-type 1 make-fa-type-primitive cdr
 448
 449 :noname ( pair obj  -- ok )
 450     2swap pair-type ensure-arg-type
 451
 452     set-car!
 453
 454     ok-symbol
 455 ; 2 make-fa-primitive set-car!
 456
 457 :noname ( pair obj -- ok )
 458     2swap pair-type ensure-arg-type
 459
 460     set-cdr!
 461
 462     ok-symbol
 463 ; 2 make-fa-primitive set-cdr!
 464
 465 \ }}}
 466
 467 \ ==== Polymorphic equality testing ==== {{{
 468
 469 :noname ( arg1 arg2 -- bool )
 470     objeq? boolean-type
 471 ; 2 make-fa-primitive eq?
 472
 473 \ }}}
 474
 475 \ ==== Input/Output ==== {{{
 476
 477 :noname ( -- port )
 478     console-i/o-port obj@
 479 ; 0 make-fa-primitive console-i/o-port
 480
 481 :noname ( -- port )
 482     current-input-port obj@
 483 ; 0 make-fa-primitive current-input-port
 484
 485 :noname ( args -- charobj )
 486     nil? if
 487         2drop current-input-port obj@
 488     else
 489         car port-type ensure-arg-type
 490     then
 491
 492     read-char
 493 ; make-primitive read-char
 494
 495 :noname ( args -- charobj )
 496     nil? if
 497         2drop current-input-port obj@
 498     else
 499         car port-type ensure-arg-type
 500     then
 501
 502     peek-char
 503 ; make-primitive peek-char
 504
 505 :noname ( args -- stringobj )
 506     nil? if
 507         2drop current-input-port obj@
 508     else
 509         car port-type ensure-arg-type
 510     then
 511
 512     read-line
 513 ; make-primitive read-line
 514
 515 : charlist>cstr ( charlist addr -- n )
 516
 517     dup 2swap ( origaddr addr charlist )
 518
 519     begin
 520         nil? false =
 521     while
 522         2dup cdr 2swap car
 523         drop ( origaddr addr charlist char )
 524         -rot 2swap ( origaddr charlist addr char )
 525         over !
 526         1+ -rot ( origaddr nextaddr charlist )
 527     repeat
 528
 529     2drop ( origaddr finaladdr )
 530     swap -
 531 ;
 532
 533 :noname ( args -- finalResult )
 534     drop pair-type
 535     pad charlist>cstr
 536     pad swap load
 537 ; string-type 1 make-fa-type-primitive load
 538
 539 :noname ( args -- obj )
 540     read
 541 ; 0 make-fa-primitive read
 542
 543 defer display
 544
 545 :noname ( obj -- none )
 546     print none
 547 ; 1 make-fa-primitive write
 548
 549 : displaypair ( pairobj -- )
 550     2dup
 551     car display
 552     cdr
 553     nil? if 2drop exit then
 554     pair-type istype? if space recurse exit then
 555     ."  . " display
 556 ;
 557
 558 : displaychar ( charobj -- )
 559     drop emit ;
 560
 561 : (displaystring) ( charlist -- )
 562     nil? if
 563         2drop
 564     else
 565         2dup car displaychar
 566         cdr recurse
 567     then
 568 ;
 569
 570 : displaystring ( stringobj -- )
 571     drop pair-type (displaystring)
 572 ;
 573
 574 :noname ( obj -- )
 575     pair-type istype? if ." (" displaypair ." )" exit then
 576     character-type istype? if displaychar exit then
 577     string-type istype? if displaystring exit then
 578
 579     print
 580 ; is display
 581
 582 :noname ( stringobj -- none )
 583     displaystring none
 584 ; string-type 1 make-fa-type-primitive display-string
 585
 586 :noname ( charobj -- none )
 587     displaychar none
 588 ; character-type 1 make-fa-type-primitive display-character
 589
 590 :noname ( obj -- none )
 591     display none
 592 ; 1 make-fa-primitive display
 593
 594 :noname ( args -- none )
 595     cr none
 596 ; 0 make-fa-primitive newline
 597
 598 \ }}}
 599
 600 \ ==== Evaluation ==== {{{
 601
 602 :noname ( args -- result )
 603     2dup car 2swap cdr
 604
 605     nil? false = if car then ( proc argvals )
 606
 607     2swap apply
 608 ; make-primitive apply
 609
 610 :noname ( proc -- result )
 611     make-continuation
 612
 613     ( Note that we get to this point either when
 614     make-continuation is originally called or when
 615     restore-continuation is called.  Since we don't
 616     want to call proc again following a restore,
 617     we use the boolean values placed on the parameter
 618     stack by make-continuation and restore-continuation
 619     to detect which call got us here and act accordingly. )
 620
 621     drop if
 622         nil cons
 623         2swap apply
 624     else
 625         2swap 2drop
 626     then
 627
 628 ; 1 make-fa-primitive call-with-current-continuation
 629
 630 \ }}}
 631
 632 \ ==== Miscellaneous  ==== {{{
 633
 634 ( Produce a recoverable exception. )
 635 :noname ( args -- result )
 636     bold fg red
 637
 638     nil? if
 639         ." Error."
 640     else
 641         ." Error:"
 642
 643         2dup car space display
 644         cdr nil? invert if
 645             begin
 646                 2dup car space print
 647                 cdr nil?
 648             until
 649         then
 650
 651         2drop
 652     then
 653
 654     reset-term
 655
 656     recoverable-exception throw
 657 ; make-primitive error
 658
 659 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
 660 :noname ( args -- result )
 661     [char] _  character-type nil cons
 662     drop symbol-type
 663 ; 0 make-fa-primitive gensym
 664
 665 ( Generate the NONE object indicating an unspecified return value. )
 666 :noname ( args -- result )
 667     none
 668 ; 0 make-fa-primitive none
 669
 670 \ }}}
 671
 672 \ vim:fdm=marker