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
 227 ( Find the GCD of n1 and n2 where n2 < n1. )
 228 : gcd ( n1 n2 -- m )
 229
 230 ;
 231
 232 \ --- Flonums ---
 233
 234 :noname ( flonum flonum -- bool )
 235     objeq? boolean-type
 236 ; 2 make-fa-primitive flo:=
 237
 238 :noname ( flonum flonum -- bool )
 239     drop swap drop f< boolean-type
 240 ; 2 make-fa-primitive flo:<
 241
 242 :noname ( flonum flonum -- bool )
 243     drop swap drop f> boolean-type
 244 ; 2 make-fa-primitive flo:>
 245
 246
 247 :noname ( flonum -- bool )
 248     drop 0.0 = boolean-type
 249 ; 1 make-fa-primitive flo:zero?
 250
 251 :noname ( flonum -- bool )
 252     drop 0.0 f> boolean-type
 253 ; 1 make-fa-primitive flo:positive?
 254
 255 :noname ( flonum -- bool )
 256     drop 0.0 f< boolean-type
 257 ; 1 make-fa-primitive flo:negative?
 258
 259
 260 :noname ( flonum1 flonum2 -- flonum1+flonum2 )
 261     drop swap drop f+ flonum-type
 262 ; 2 make-fa-primitive flo:+
 263
 264 :noname ( flonum1 flonum2 -- flonum1-flonum2 )
 265     drop swap drop f- flonum-type
 266 ; 2 make-fa-primitive flo:-
 267
 268 :noname ( flonum1 flonum2 -- flonum1*flonum2 )
 269     drop swap drop f* flonum-type
 270 ; 2 make-fa-primitive flo:*
 271
 272 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 273     drop swap drop f/ flonum-type
 274 ; 2 make-fa-primitive flo:/
 275
 276 :noname ( flonum1 flonum2 -- flonum1/flonum2 )
 277     drop swap drop f/ flonum-type
 278 ; 2 make-fa-primitive flo:/
 279
 280
 281 :noname ( flonum -- bool )
 282     drop dup
 283     fnan? swap finf? or invert
 284 ; 1 make-fa-primitive flo:finite?
 285
 286
 287 :noname ( flonum -- flonum )
 288     swap -1.0 f* swap
 289 ; 1 make-fa-primitive flo:neg
 290
 291 :noname ( flonum -- flonum )
 292     swap fabs swap
 293 ; 1 make-fa-primitive flo:abs
 294
 295 :noname ( flonum -- flonum )
 296     swap fexp swap
 297 ; 1 make-fa-primitive flo:exp
 298
 299 :noname ( flonum -- flonum )
 300     swap flog swap
 301 ; 1 make-fa-primitive flo:log
 302
 303 :noname ( flonum -- flonum )
 304     swap fsin swap
 305 ; 1 make-fa-primitive flo:sin
 306
 307 :noname ( flonum -- flonum )
 308     swap fcos swap
 309 ; 1 make-fa-primitive flo:cos
 310
 311 :noname ( flonum -- flonum )
 312     swap ftan swap
 313 ; 1 make-fa-primitive flo:tan
 314
 315 :noname ( flonum -- flonum )
 316     swap fasin swap
 317 ; 1 make-fa-primitive flo:asin
 318
 319 :noname ( flonum -- flonum )
 320     swap facos swap
 321 ; 1 make-fa-primitive flo:acos
 322
 323 :noname ( flonum -- flonum )
 324     swap fatan swap
 325 ; 1 make-fa-primitive flo:atan
 326
 327 :noname ( flonum -- flonum )
 328     swap fsqrt swap
 329 ; 1 make-fa-primitive flo:sqrt
 330
 331 :noname ( flonum flonum -- flonum )
 332     drop swap drop f^ flonum-type
 333 ; 2 make-fa-primitive flo:expt
 334
 335 :noname ( flonum -- flonum )
 336     swap floor swap
 337 ; 1 make-fa-primitive flo:floor
 338
 339 :noname ( flonum -- flonum )
 340     swap ceiling swap
 341 ; 1 make-fa-primitive flo:ceiling
 342
 343 :noname ( flonum -- flonum )
 344     swap truncate swap
 345 ; 1 make-fa-primitive flo:truncate
 346
 347 :noname ( flonum -- flonum )
 348     swap fround swap
 349 ; 1 make-fa-primitive flo:round
 350
 351 :noname ( flonum -- flonum )
 352     drop floor f->i fixnum-type
 353 ; 1 make-fa-primitive flo:floor->exact
 354
 355 :noname ( flonum -- flonum )
 356     drop ceiling f->i fixnum-type
 357 ; 1 make-fa-primitive flo:ceiling->exact
 358
 359 :noname ( flonum -- flonum )
 360     drop truncate f->i fixnum-type
 361 ; 1 make-fa-primitive flo:truncate->exact
 362
 363 :noname ( flonum -- flonum )
 364     drop f->i fixnum-type
 365 ; 1 make-fa-primitive flo:round->exact
 366
 367 :noname ( flonum flonum -- flonum )
 368     drop swap drop f/ fatan flonum-type
 369 ; 2 make-fa-primitive flo:atan2
 370
 371
 372 \ --- Conversion ---
 373
 374 :noname ( fixnum -- flonum )
 375     drop i->f flonum-type
 376 ; 1 make-fa-primitive fixnum->flonum
 377
 378 \ }}}
 379
 380 \ ==== Pairs and Lists ==== {{{
 381
 382 :noname ( arg1 arg2 -- pair )
 383     cons
 384 ; 2 make-fa-primitive cons
 385
 386 :noname ( pair-obj -- obj )
 387     car
 388 ; pair-type 1 make-fa-type-primitive car
 389
 390 :noname ( args -- obj )
 391     cdr
 392 ; pair-type 1 make-fa-type-primitive cdr
 393
 394 :noname ( pair obj  -- ok )
 395     2swap pair-type ensure-arg-type
 396
 397     set-car!
 398
 399     ok-symbol
 400 ; 2 make-fa-primitive set-car!
 401
 402 :noname ( pair obj -- ok )
 403     2swap pair-type ensure-arg-type
 404
 405     set-cdr!
 406
 407     ok-symbol
 408 ; 2 make-fa-primitive set-cdr!
 409
 410 \ }}}
 411
 412 \ ==== Polymorphic equality testing ==== {{{
 413
 414 :noname ( arg1 arg2 -- bool )
 415     objeq? boolean-type
 416 ; 2 make-fa-primitive eq?
 417
 418 \ }}}
 419
 420 \ ==== Input/Output ==== {{{
 421
 422 :noname ( args -- finalResult )
 423     drop pair-type
 424     pad charlist>cstr
 425     pad swap load
 426 ; string-type 1 make-fa-type-primitive load
 427
 428 :noname ( args -- obj )
 429     read
 430 ; 0 make-fa-primitive read
 431
 432 defer display
 433
 434 :noname ( obj -- none )
 435     print none
 436 ; 1 make-fa-primitive write
 437
 438 : displaypair ( pairobj -- )
 439     2dup
 440     car display
 441     cdr
 442     nil? if 2drop exit then
 443     pair-type istype? if space recurse exit then
 444     ."  . " display
 445 ;
 446
 447 : displaychar ( charobj -- )
 448     drop emit ;
 449
 450 : (displaystring) ( charlist -- )
 451     nil? if
 452         2drop
 453     else
 454         2dup car displaychar
 455         cdr recurse
 456     then
 457 ;
 458
 459 : displaystring ( stringobj -- )
 460     drop pair-type (displaystring)
 461 ;
 462
 463 :noname ( obj -- )
 464     pair-type istype? if ." (" displaypair ." )" exit then
 465     character-type istype? if displaychar exit then
 466     string-type istype? if displaystring exit then
 467
 468     print
 469 ; is display
 470
 471 :noname ( stringobj -- none )
 472     displaystring none
 473 ; string-type 1 make-fa-type-primitive display-string
 474
 475 :noname ( charobj -- none )
 476     displaychar none
 477 ; character-type 1 make-fa-type-primitive display-character
 478
 479 :noname ( obj -- none )
 480     display none
 481 ; 1 make-fa-primitive display
 482
 483 :noname ( args -- none )
 484     cr none
 485 ; 0 make-fa-primitive newline
 486
 487 \ }}}
 488
 489 \ ==== Evaluation ==== {{{
 490
 491 :noname ( args -- result )
 492     2dup car 2swap cdr
 493
 494     nil? false = if car then ( proc argvals )
 495
 496     apply
 497 ; make-primitive apply
 498
 499 \ }}}
 500
 501 \ ==== Miscellaneous  ==== {{{
 502
 503 ( Produce a recoverable exception. )
 504 :noname ( args -- result )
 505     bold fg red
 506
 507     nil? if
 508         ." Error."
 509     else
 510         ." Error: " car display
 511     then
 512
 513     reset-term
 514
 515     recoverable-exception throw
 516 ; make-primitive error
 517
 518 ( Generate a temporary unique symbol. Used in the creation of hygienic macros. )
 519 :noname ( args -- result )
 520     [char] _  character-type nil cons
 521     drop symbol-type
 522 ; 0 make-fa-primitive gensym
 523
 524 ( Generate the NONE object indicating an unspecified return value. )
 525 :noname ( args -- result )
 526     none
 527 ; 0 make-fa-primitive none
 528
 529 \ }}}
 530
 531 \ vim:fdm=marker