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