From: Tim Vaughan Date: Sun, 13 Nov 2016 01:40:03 +0000 (+1300) Subject: Redefined numeric procs in terms of fixnum prims. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;ds=inline;h=73373387ae07d9da0ee049d96338555707b6d7b7;p=scheme.forth.jl.git Redefined numeric procs in terms of fixnum prims. --- diff --git a/src/float.4th b/src/float.4th index 95aaa3b..74a4f08 100644 --- a/src/float.4th +++ b/src/float.4th @@ -29,16 +29,3 @@ CODE f/ a = reinterpret(Float64, popPS()) pushPS(reinterpret(Int64, a/b)) END-CODE - -( addr len -- float ) -CODE float-parse - len = popPS() - addr = popPS() - val = parse(Float64, getString(addr, len)) - pushPS(reinterpret(Int64, val)) -END-CODE - -( float -- ) -CODE float-print - print(reinterpret(Float64, popPS())) -END-CODE \ No newline at end of file diff --git a/src/scheme-library.scm b/src/scheme-library.scm index 484f500..8260f90 100644 --- a/src/scheme-library.scm +++ b/src/scheme-library.scm @@ -2,10 +2,90 @@ ;; Standard Library Procedures and Macros ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; NUMBERS + +; Arithmetic + +(define (null? arg) + (eq? arg '())) + +(define (fold-left proc init l) + (if (null? l) + init + (fold-left proc (proc init (car l)) (cdr l)))) + +(define (reduce-left proc init l) + (if (null? l) + init + (if (null? (cdr l)) + (car l) + (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l)))))) + +(define (+ . args) + (fold-left fix:+ 0 args)) + +(define (- first . rest) + (if (null? rest) + (fix:neg first) + (fix:- first (apply + rest)))) + +(define (* . args) + (fold-left fix:* 1 args)) + +(define (quotient n1 n2) + (fix:quotient n1 n2)) + +(define (remainder n1 n2) + (fix:remainder n1 n2)) + +(define modulo remainder) + +(define (1+ n) + (fix:1+ n)) + +(define (-1+ n) + (fix:-1+ n)) + +; Relations + +(define (test-relation rel l) + (if (null? l) + #t + (if (null? (cdr l)) + #t + (if (rel (car l) (car (cdr l))) + (test-relation rel (cdr l)) + #f)))) + +(define (= . args) + (test-relation fix:= args)) + +(define (> . args) + (test-relation fix:> args)) + +(define (< . args) + (test-relation fix:< args)) + +(define (>= . args) + (test-relation fix:>= args)) + +(define (<= . args) + (test-relation fix:<= args)) + + + +; Current state of the numerical tower +(define complex? #f) +(define real? #f) +(define rational? #t) +(define integer? #t) +(define exact? #t) +(define inexact? #t) + ;; LISTS -(define (null? args) - (eq? args ())) +(define (list . args) args) + (define (caar l) (car (car l))) (define (cadr l) (car (cdr l))) diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th index edf5894..9203f71 100644 --- a/src/scheme-primitives.4th +++ b/src/scheme-primitives.4th @@ -1,52 +1,36 @@ \ ==== Type predicates ==== {{{ :noname ( args -- boolobj ) - 2dup 1 ensure-arg-count - - car nil objeq? boolean-type -; make-primitive null? + nil objeq? boolean-type +; 1 make-fa-primitive null? :noname ( args -- boolobj ) - 2dup 1 ensure-arg-count - - car boolean-type istype? -rot 2drop boolean-type -; make-primitive boolean? + boolean-type istype? -rot 2drop boolean-type +; 1 make-fa-primitive boolean? :noname ( args -- boolobj ) - 2dup 1 ensure-arg-count - - car symbol-type istype? -rot 2drop boolean-type -; make-primitive symbol? + symbol-type istype? -rot 2drop boolean-type +; 1 make-fa-primitive symbol? :noname ( args -- boolobj ) - 2dup 1 ensure-arg-count - - car fixnum-type istype? -rot 2drop boolean-type -; make-primitive integer? + fixnum-type istype? -rot 2drop boolean-type +; 1 make-fa-primitive fixnum? :noname ( args -- boolobj ) - 2dup 1 ensure-arg-count - - car character-type istype? -rot 2drop boolean-type -; make-primitive char? + character-type istype? -rot 2drop boolean-type +; 1 make-fa-primitive char? :noname ( args -- boolobj ) - 2dup 1 ensure-arg-count - - car string-type istype? -rot 2drop boolean-type -; make-primitive string? + string-type istype? -rot 2drop boolean-type +; 1 make-fa-primitive string? :noname ( args -- boolobj ) - 2dup 1 ensure-arg-count - - car pair-type istype? -rot 2drop boolean-type -; make-primitive pair? + pair-type istype? -rot 2drop boolean-type +; 1 make-fa-primitive pair? :noname ( args -- boolobj ) - 2dup 1 ensure-arg-count - - car primitive-proc-type istype? -rot 2drop boolean-type -; make-primitive procedure? + primitive-proc-type istype? -rot 2drop boolean-type +; 1 make-fa-primitive procedure? \ }}} @@ -157,224 +141,138 @@ \ }}} -\ ==== Arithmetic ==== {{{ - -: add-prim ( args -- fixnum ) - 2dup nil objeq? if - 2drop - 0 fixnum-type - else - 2dup car drop - -rot cdr recurse drop - + fixnum-type - then -; -' add-prim make-primitive + - -:noname ( args -- fixnum ) - 2dup nil objeq? if - 2drop - 0 fixnum-type - else - 2dup car drop - -rot cdr - 2dup nil objeq? if - 2drop negate - else - add-prim drop - - - then - fixnum-type - then -; make-primitive - - -:noname ( args -- fixnum ) - 2dup nil objeq? if - 2drop - 1 fixnum-type - else - 2dup car drop - -rot cdr recurse drop - * fixnum-type - then -; make-primitive * - -:noname ( args -- fixnum ) - 2dup 2 ensure-arg-count - - 2dup car fixnum-type ensure-arg-type - 2swap cdr car fixnum-type ensure-arg-type +\ ==== Primitivle Arithmetic ==== {{{ - drop swap drop +\ --- Fixnums --- - / fixnum-type -; make-primitive quotient +:noname ( fixnum fixnum -- boolobj ) + objeq? boolean-type +; 2 make-fa-primitive fix:= -:noname ( args -- fixnum ) - 2dup 2 ensure-arg-count +:noname ( fixnum fixnum -- boolobj ) + drop swap drop < boolean-type +; 2 make-fa-primitive fix:< - 2dup car fixnum-type ensure-arg-type - 2swap cdr car fixnum-type ensure-arg-type +:noname ( fixnum fixnum -- boolobj ) + drop swap drop > boolean-type +; 2 make-fa-primitive fix:> - drop swap drop +:noname ( fixnum fixnum -- boolobj ) + drop swap drop <= boolean-type +; 2 make-fa-primitive fix:<= - mod fixnum-type -; make-primitive remainder +:noname ( fixnum fixnum -- boolobj ) + drop swap drop >= boolean-type +; 2 make-fa-primitive fix:>= -variable relcfa +:noname ( fixnum fixnum -- boolobj ) + drop 0= boolean-type +; 1 make-fa-primitive fix:zero? -: test-relation ( args -- bool ) +:noname ( fixnum fixnum -- boolobj ) + drop 0> boolean-type +; 1 make-fa-primitive fix:positive? - 2dup nil objeq? if - 2drop - true boolean-type exit - then +:noname ( fixnum fixnum -- boolobj ) + drop 0< boolean-type +; 1 make-fa-primitive fix:negative? - ( args ) +:noname ( fixnum fixnum -- fixnum' ) + drop swap drop + fixnum-type +; 2 make-fa-primitive fix:+ - 2dup car fixnum-type ensure-arg-type ( args arg0 ) - 2swap cdr ( arg0 args' ) +:noname ( fixnum fixnum -- fixnum' ) + drop swap drop - fixnum-type +; 2 make-fa-primitive fix:- - 2dup nil objeq? if - 2drop 2drop - true boolean-type exit - then +:noname ( fixnum fixnum -- fixnum' ) + drop swap drop * fixnum-type +; 2 make-fa-primitive fix:* - ( arg0 args' ) +:noname ( fixnum fixnum -- fixnum' ) + drop swap drop / fixnum-type +; 2 make-fa-primitive fix:quotient - begin - 2dup nil objeq? false = - while - 2dup car fixnum-type ensure-arg-type ( arg0 args' arg1 ) - 2rot 2swap 2dup 2rot 2swap ( args' arg1 arg1 arg0 ) - relcfa @ execute false = if - 2drop 2drop - false boolean-type exit - then +:noname ( fixnum fixnum -- fixnum' ) + drop swap drop mod fixnum-type +; 2 make-fa-primitive fix:remainder - 2swap cdr ( arg0 args'' ) - repeat +:noname ( fixnum -- fixnum+1 ) + swap 1+ swap +; 1 make-fa-primitive fix:1+ - 2drop 2drop - true boolean-type -; +:noname ( fixnum -- fixnum-1 ) + swap 1- swap +; 1 make-fa-primitive fix:-1+ -: fixnum-lt ( obj1 obj2 -- bool ) - drop swap drop < -; +:noname ( fixnum -- -fixnum ) + swap negate swap +; 1 make-fa-primitive fix:neg -:noname - ['] fixnum-lt relcfa ! - test-relation -; make-primitive < - -: fixnum-gt ( obj1 obj2 -- bool ) - drop swap drop > -; - -:noname - ['] fixnum-gt relcfa ! - test-relation -; make-primitive > - -: fixnum-eq ( obj1 obj2 -- bool ) - drop swap drop = +( Find the GCD of n1 and n2 where n2 < n1. ) +: gcd ( n1 n2 -- m ) + ; -:noname - ['] fixnum-eq relcfa ! - test-relation -; make-primitive = - -hide relcfa - \ }}} \ ==== Pairs and Lists ==== {{{ -:noname ( args -- pair ) - 2dup 2 ensure-arg-count - - 2dup car 2swap cdr car +:noname ( arg1 arg2 -- pair ) cons -; make-primitive cons - -:noname ( args -- list ) - \ args is already a list! -; make-primitive list - -:noname ( args -- obj ) - 2dup 1 ensure-arg-count - car pair-type ensure-arg-type +; 2 make-fa-primitive cons +:noname ( pair-obj -- obj ) car -; make-primitive car +; pair-type 1 make-fa-type-primitive car :noname ( args -- obj ) - 2dup 1 ensure-arg-count - car pair-type ensure-arg-type - cdr -; make-primitive cdr +; pair-type 1 make-fa-type-primitive cdr -:noname ( args -- ok ) - 2dup 2 ensure-arg-count - 2dup cdr car - 2swap car pair-type ensure-arg-type +:noname ( pair obj -- ok ) + 2swap pair-type ensure-arg-type set-car! ok-symbol -; make-primitive set-car! +; 2 make-fa-primitive set-car! -:noname ( args -- ok ) - 2dup 2 ensure-arg-count - 2dup cdr car - 2swap car pair-type ensure-arg-type +:noname ( pair obj -- ok ) + 2swap pair-type ensure-arg-type set-cdr! ok-symbol -; make-primitive set-cdr! +; 2 make-fa-primitive set-cdr! \ }}} \ ==== Polymorphic equality testing ==== {{{ -:noname ( args -- bool ) - 2dup 2 ensure-arg-count - 2dup cdr car - 2swap car - +:noname ( arg1 arg2 -- bool ) objeq? boolean-type -; make-primitive eq? +; 2 make-fa-primitive eq? \ }}} \ ==== Input/Output ==== {{{ :noname ( args -- finalResult ) - 2dup 1 ensure-arg-count - car string-type ensure-arg-type - drop pair-type pad charlist>cstr pad swap load -; make-primitive load +; string-type 1 make-fa-type-primitive load :noname ( args -- obj ) - 0 ensure-arg-count read -; make-primitive read +; 0 make-fa-primitive read defer display -:noname ( args -- none ) - 2dup 1 ensure-arg-count - car print - - none -; make-primitive write +:noname ( obj -- none ) + print none +; 1 make-fa-primitive write : displaypair ( pairobj -- ) 2dup @@ -409,40 +307,21 @@ defer display print ; is display -:noname ( args -- none ) - 2dup 1 ensure-arg-count - car string-type ensure-arg-type - - displaystring - - none -; make-primitive display-string - -:noname ( args -- none ) - 2dup 1 ensure-arg-count - car character-type ensure-arg-type - - displaychar - - none -; make-primitive display-character - -:noname ( args -- none ) - 2dup 1 ensure-arg-count - car +:noname ( stringobj -- none ) + displaystring none +; string-type 1 make-fa-type-primitive display-string - display +:noname ( charobj -- none ) + displaychar none +; character-type 1 make-fa-type-primitive display-character - none -; make-primitive display +:noname ( obj -- none ) + display none +; 1 make-fa-primitive display :noname ( args -- none ) - 0 ensure-arg-count - - cr - - none -; make-primitive newline + cr none +; 0 make-fa-primitive newline \ }}} @@ -477,18 +356,14 @@ defer display ( 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 +; 0 make-fa-primitive gensym ( Generate the NONE object indicating an unspecified return value. ) :noname ( args -- result ) - 0 ensure-arg-count - none -; make-primitive none +; 0 make-fa-primitive none \ }}} diff --git a/src/scheme.4th b/src/scheme.4th index f8dd089..165d88f 100644 --- a/src/scheme.4th +++ b/src/scheme.4th @@ -24,7 +24,6 @@ variable nexttype does> @ ; make-type fixnum-type -make-type realnum-type make-type boolean-type make-type character-type make-type string-type @@ -436,8 +435,6 @@ global-env obj! bl word count - \ 2dup ." Defining primitive " type ." ..." cr - cstr>charlist charlist>symbol @@ -459,6 +456,82 @@ global-env obj! then ; +: ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- ) + dup 0= if + drop nil objeq? false = if + recoverable-exception throw" Too many arguments for primitive procedure." + then + else + -rot nil? if + recoverable-exception throw" Too few arguments for primitive procedure." + then + + 2dup cdr 2swap car ( ... t1 n args' arg1 ) + 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 ) + istype? false = if + recoverable-exception throw" Incorrect type for primitive procedure." + then + + 2drop recurse + then + +; + +: push-args-to-stack ( args -- arg1 arg2 ... argn ) + begin + nil? false = + while + 2dup car 2swap cdr + repeat + + 2drop +; + +: add-fa-checks ( cfa n -- cfa' ) + here current @ 1+ dup @ , ! + 0 , + here -rot + docol , + ['] 2dup , ['] lit , , ['] ensure-arg-count , + ['] push-args-to-stack , + ['] lit , , ['] execute , + ['] exit , +; + +: add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' ) + here current @ 1+ dup @ , ! + 0 , + here >R + docol , + ['] 2dup , + ['] >R , ['] >R , + + dup ( cfa t1 t2 ... tn n m ) + + begin + ?dup 0> + while + rot ['] lit , , ( cfa t1 t2 ... tn-1 n m ) + 1- + repeat + + ['] R> , ['] R> , + + ['] lit , , ['] ensure-arg-type-and-count , + + ['] push-args-to-stack , + ['] lit , , ['] execute , + ['] exit , + + R> +; + +: make-fa-primitive ( cfa n -- ) + add-fa-checks make-primitive ; + +: make-fa-type-primitive ( cfa t1 t2 ... tn n -- ) + add-fa-type-checks make-primitive ; + : arg-type-error bold fg red ." Incorrect argument type." reset-term cr abort @@ -667,7 +740,7 @@ parse-idx-stack parse-idx-sp ! delim? pop-parse-idx ; -: realnum? ( -- bool ) +: flonum? ( -- bool ) push-parse-idx minus? plus? or if @@ -799,24 +872,6 @@ parse-idx-stack parse-idx-sp ! fixnum-type ; -: readrealnum ( -- realnum ) - - \ Remember that at this point we're guaranteed to - \ have a parsable real on this line. - - parse-str parse-idx @ + - - begin delim? false = while - inc-parse-idx - repeat - - parse-str parse-idx @ + over - - - float-parse - - realnum-type -; - : readbool ( -- bool-obj ) inc-parse-idx @@ -938,11 +993,6 @@ parse-idx-stack parse-idx-sp ! exit then - realnum? if - readrealnum - exit - then - boolean? if readbool exit @@ -1032,7 +1082,6 @@ parse-idx-stack parse-idx-sp ! : self-evaluating? ( obj -- obj bool ) boolean-type istype? if true exit then fixnum-type istype? if true exit then - realnum-type istype? if true exit then character-type istype? if true exit then string-type istype? if true exit then nil-type istype? if true exit then @@ -1524,8 +1573,6 @@ hide env : printfixnum ( fixnumobj -- ) drop 0 .R ; -: printrealnum ( realnumobj -- ) drop float-print ; - : printbool ( numobj -- ) drop if ." #t" @@ -1596,7 +1643,6 @@ hide env :noname ( obj -- ) fixnum-type istype? if printfixnum exit then - realnum-type istype? if printrealnum exit then boolean-type istype? if printbool exit then character-type istype? if printchar exit then string-type istype? if printstring exit then