X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=blobdiff_plain;f=scheme-primitives.4th;h=edf5894ab5e87962b15abc78991e5d260f775058;hp=97c098ff8ae6716db18fe94ecd8df132fdb0e722;hb=3eaf389aa81bcfbf8dd64c89520925413d5c2390;hpb=a9e0195cd866692844586002f1614ff74a79426a diff --git a/scheme-primitives.4th b/scheme-primitives.4th index 97c098f..edf5894 100644 --- a/scheme-primitives.4th +++ b/scheme-primitives.4th @@ -1,4 +1,4 @@ -( ==== Type predicates ==== ) +\ ==== Type predicates ==== {{{ :noname ( args -- boolobj ) 2dup 1 ensure-arg-count @@ -48,7 +48,9 @@ car primitive-proc-type istype? -rot 2drop boolean-type ; make-primitive procedure? -( ==== Type conversions ==== ) +\ }}} + +\ ==== Type conversions ==== {{{ :noname ( args -- fixnum ) 2dup 1 ensure-arg-count @@ -153,7 +155,9 @@ charlist>symbol ; make-primitive string->symbol -( ==== Arithmetic ==== ) +\ }}} + +\ ==== Arithmetic ==== {{{ : add-prim ( args -- fixnum ) 2dup nil objeq? if @@ -284,7 +288,9 @@ variable relcfa hide relcfa -( ==== Pairs and Lists ==== ) +\ }}} + +\ ==== Pairs and Lists ==== {{{ :noname ( args -- pair ) 2dup 2 ensure-arg-count @@ -297,21 +303,21 @@ hide relcfa \ args is already a list! ; make-primitive list -:noname ( args -- pair ) +:noname ( args -- obj ) 2dup 1 ensure-arg-count car pair-type ensure-arg-type car ; make-primitive car -:noname ( args -- pair ) +:noname ( args -- obj ) 2dup 1 ensure-arg-count car pair-type ensure-arg-type cdr ; make-primitive cdr -:noname ( args -- pair ) +:noname ( args -- ok ) 2dup 2 ensure-arg-count 2dup cdr car 2swap car pair-type ensure-arg-type @@ -321,7 +327,7 @@ hide relcfa ok-symbol ; make-primitive set-car! -:noname ( args -- pair ) +:noname ( args -- ok ) 2dup 2 ensure-arg-count 2dup cdr car 2swap car pair-type ensure-arg-type @@ -331,7 +337,9 @@ hide relcfa ok-symbol ; make-primitive set-cdr! -( ==== Polymorphic equality testing ==== ) +\ }}} + +\ ==== Polymorphic equality testing ==== {{{ :noname ( args -- bool ) 2dup 2 ensure-arg-count @@ -341,7 +349,9 @@ hide relcfa objeq? boolean-type ; make-primitive eq? -( ==== Input/Output ==== ) +\ }}} + +\ ==== Input/Output ==== {{{ :noname ( args -- finalResult ) 2dup 1 ensure-arg-count @@ -352,7 +362,10 @@ hide relcfa pad swap load ; make-primitive load -' read make-primitive read +:noname ( args -- obj ) + 0 ensure-arg-count + read +; make-primitive read defer display :noname ( args -- none ) @@ -367,19 +380,31 @@ defer display 2dup car display cdr - nil-type istype? if 2drop exit then + nil? if 2drop exit then pair-type istype? if space recurse exit then ." . " display ; : displaychar ( charobj -- ) - drop emit + drop emit ; + +: (displaystring) ( charlist -- ) + nil? if + 2drop + else + 2dup car displaychar + cdr recurse + then +; + +: displaystring ( stringobj -- ) + drop pair-type (displaystring) ; :noname ( obj -- ) pair-type istype? if ." (" displaypair ." )" exit then character-type istype? if displaychar exit then - string-type istype? if (printstring) exit then + string-type istype? if displaystring exit then print ; is display @@ -388,7 +413,7 @@ defer display 2dup 1 ensure-arg-count car string-type ensure-arg-type - (printstring) + displaystring none ; make-primitive display-string @@ -419,7 +444,9 @@ defer display none ; make-primitive newline -( ==== Evaluation ==== ) +\ }}} + +\ ==== Evaluation ==== {{{ :noname ( args -- result ) 2dup car 2swap cdr @@ -428,3 +455,41 @@ defer display apply ; make-primitive apply + +\ }}} + +\ ==== Miscellaneous ==== {{{ + +( Produce a recoverable exception. ) +:noname ( args -- result ) + bold fg red + + nil? if + ." Error." + else + ." Error: " car display + then + + reset-term + + recoverable-exception throw +; make-primitive error + +( Generate a temporary unique symbol. Used in the creation of hygienic macros. ) +:noname ( args -- result ) + 0 ensure-arg-count + + [char] _ character-type nil cons + drop symbol-type +; make-primitive gensym + +( Generate the NONE object indicating an unspecified return value. ) +:noname ( args -- result ) + 0 ensure-arg-count + + none +; make-primitive none + +\ }}} + +\ vim:fdm=marker