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