X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=scheme.4th;h=3728257eb997f7203c541dcadd0c885a0da1edec;hb=9be58bf752f3b2c5b0b6c6880f77b482e9da0ffd;hp=c4a08cfa4a61d7a8625e78d5eccdd035cf14248b;hpb=d2dc6c641693e0db30a8e11d7cb404148ba95838;p=scheme.forth.jl.git diff --git a/scheme.4th b/scheme.4th index c4a08cf..3728257 100644 --- a/scheme.4th +++ b/scheme.4th @@ -271,7 +271,6 @@ create-symbol if if-symbol create-symbol lambda lambda-symbol create-symbol λ λ-symbol create-symbol begin begin-symbol -create-symbol apply apply-symbol \ }}} @@ -397,6 +396,54 @@ objvar global-env nil nil nil extend-env global-env obj! +\ }}} + +\ ---- Primitives ---- {{{ + +: make-primitive ( cfa -- ) + bl word + count + + \ 2dup ." Defining primitive " type ." ..." cr + + cstr>charlist + charlist>symbol + + rot primitive-proc-type ( var prim ) + global-env obj@ define-var +; + +: arg-count-error + bold fg red ." Incorrect argument count." reset-term cr + abort +; + +: ensure-arg-count ( args n -- ) + dup 0= if + drop nil objeq? false = if + arg-count-error + then + else + -rot nil? if + arg-count-error + then + + cdr rot 1- recurse + then +; + +: arg-type-error + bold fg red ." Incorrect argument type." reset-term cr + abort +; + +: ensure-arg-type ( arg type -- arg ) + istype? false = if + arg-type-error + then +; + + \ }}} \ ---- Macros ---- {{{ @@ -975,19 +1022,32 @@ parse-idx-stack parse-idx-sp ! : make-lambda ( params body -- lambda-exp ) lambda-symbol -2rot cons cons ; -: definition-var ( obj -- var ) - cdr car - symbol-type istype? false = if car then -; +( Handles recursive expansion of defines in + terms of nested lambdas. Most Schemes only + handle one level of expansion! ) +: (definition-var-val) ( val var -- val' var' ) + symbol-type istype? if 2swap car 2swap exit then -: definition-val ( obj -- val ) - 2dup cdr car symbol-type istype? if - 2drop - cdr cdr car - else - cdr 2swap cdr cdr - make-lambda + 2dup cdr 2swap car + symbol-type istype? if + 2swap ( body procname procargs ) + 2rot ( procname procargs body ) + make-lambda ( procname lambda-exp ) + 2swap + exit then + + ( body procargs nextval ) + -2rot 2swap ( nextval procargs body ) + make-lambda nil cons ( nextval lambda-exp ) + 2swap ( lambda-exp nextval ) + recurse +; + +: definition-var-val ( obj -- var val ) + cdr 2dup cdr 2swap car + (definition-var-val) + 2swap ; : assignment? ( obj -- obj bool ) @@ -1000,12 +1060,9 @@ parse-idx-stack parse-idx-sp ! cdr cdr car ; : eval-definition ( obj env -- res ) - 2swap - 2over 2over ( env obj env obj ) - definition-val 2swap ( env obj valexp env ) - eval ( env obj val ) - - 2swap definition-var 2swap ( env var val ) + 2dup 2rot ( env env obj ) + definition-var-val ( env env var val ) + 2rot eval ( env var val ) 2rot ( var val env ) define-var @@ -1166,7 +1223,15 @@ hide env ( Ensure terminating symbol arg name is handled specially to allow for variadic procedures. ) : flatten-proc-args ( argvals argnames -- argvals' argnames' ) - nil? if exit then + nil? if + 2over nil? false = if + bold fg red ." Too many arguments supplied to compound method. Aborting." reset-term cr + abort + else + 2drop + then + exit + then symbol-type istype? if nil cons @@ -1176,7 +1241,16 @@ hide env exit then - 2over cdr 2over cdr + 2over + nil? if + bold fg red ." Too few arguments supplied to compound method. Aborting." reset-term cr + abort + else + cdr + then + + 2over cdr + recurse ( argvals argnames argvals'' argnames'' ) 2rot car 2swap cons ( argvals argvals'' argnames' ) 2rot car 2rot cons ( argnames' argvals' ) @@ -1290,25 +1364,6 @@ hide env 2over 2over ( env exp env exp ) operator ( env exp env opname ) - 2dup apply-symbol objeq? if - - 2drop 2swap ( env env exp ) - cdr 2dup car 2rot ( env expbody real-opname env ) - eval ( env expbody proc ) - 2swap cdr - nil? false = if car then ( env proc real-operand ) - - 2rot eval ( proc argvals ) - - pair-type istype? false = if - bold fg red ." Error: apply requires a list of operand arguments." cr - reset-term abort - then - - apply - exit - then - 2dup lookup-macro nil? false = if \ Macro function evaluation @@ -1321,19 +1376,20 @@ hide env 2swap ['] eval goto-deferred - then + else + \ Regular function application - \ Regular function application + 2drop ( env exp env opname ) - 2drop ( env exp env opname ) + 2swap eval ( env exp proc ) - 2swap eval ( env exp proc ) - -2rot ( proc env exp ) - operands 2swap ( proc operands env ) - list-of-vals ( proc argvals ) + -2rot ( proc env exp ) + operands 2swap ( proc operands env ) + list-of-vals ( proc argvals ) - apply - exit + apply + exit + then then bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr @@ -1579,57 +1635,10 @@ variable gc-stack-depth \ }}} -\ ---- Primitives ---- {{{ - -: make-primitive ( cfa -- ) - bl word - count - - \ 2dup ." Defining primitive " type ." ..." cr - - cstr>charlist - charlist>symbol - - rot primitive-proc-type ( var prim ) - global-env obj@ define-var -; - -: arg-count-error - bold fg red ." Incorrect argument count." reset-term cr - abort -; - -: ensure-arg-count ( args n -- ) - dup 0= if - drop nil objeq? false = if - arg-count-error - then - else - -rot nil? if - arg-count-error - then - - cdr rot 1- recurse - then -; - -: arg-type-error - bold fg red ." Incorrect argument type." reset-term cr - abort -; - -: ensure-arg-type ( arg type -- arg ) - istype? false = if - arg-type-error - then -; - -include scheme-primitives.4th - -\ }}} - \ ---- Standard Library ---- {{{ + include scheme-primitives.4th + s" scheme-library.scm" load 2drop \ }}}