From: Tim Vaughan <tgvaughan@gmail.com>
Date: Tue, 27 Jun 2017 20:19:37 +0000 (+1200)
Subject: Merged macro quasiquote into analyze.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=commitdiff_plain;h=632cf90c6a97b1ee01a13ab424051f0a99c4a150;hp=-c

Merged macro quasiquote into analyze.
---

632cf90c6a97b1ee01a13ab424051f0a99c4a150
diff --combined src/scheme.4th
index 4d5e33b,abd214e..e5ac9cd
--- a/src/scheme.4th
+++ b/src/scheme.4th
@@@ -3,7 -3,6 +3,7 @@@ scheme definition
  
  include term-colours.4th
  include defer-is.4th
 +include goto.4th
  include catch-throw.4th
  include integer.4th
  include float.4th
@@@ -12,7 -11,6 +12,7 @@@ include debugging.4t
  
  defer read
  defer expand
 +defer analyze
  defer eval
  defer print
  
@@@ -164,10 -162,6 +164,10 @@@ variable nextfre
      R> R>
  ;
  
 +: 2pick ( an bn an-1 bn-1 ... a0 b0 n -- an bn an-1 bn-1 ... a0 b0 an bn )
 +    2* 1+ dup
 +    >R pick R> pick ;
 +
  \ }}}
  
  \ ---- Pre-defined symbols ---- {{{
@@@ -1315,95 -1309,6 +1315,6 @@@ parse-idx-stack parse-idx-sp 
  : quote-body ( quote-obj -- quote-body-obj )
      cdr car ;
  
- : quasiquote? ( obj -- obj bool )
-     quasiquote-symbol tagged-list? ;
- 
- : unquote? ( obj -- obj bool )
-     unquote-symbol tagged-list? ;
- 
- : unquote-splicing? ( obj -- obj bool )
-     unquote-splicing-symbol tagged-list? ;
- 
- : eval-unquote ( env obj -- res )
-     cdr ( env args )
- 
-     nil? if
-         except-message: ." no arguments to unquote." recoverable-exception throw
-     then
- 
-     2dup cdr
-     nil? false = if
-         except-message: ." too many arguments to unquote." recoverable-exception throw
-     then
- 
-     2drop car 2swap eval
- ;
- 
- ( Create a new list from elements of l1 consed on to l2 )
- : join-lists ( l2 l1 -- l3 )
-     nil? if 2drop exit then
- 
-     2dup car
-     -2rot cdr
-     recurse cons
- ;
- 
- defer eval-quasiquote-item
- : eval-quasiquote-pair ( env obj -- res )
-     2over 2over ( env obj env obj )
- 
-     cdr eval-quasiquote-item
- 
-     -2rot car ( cdritem env objcar )
- 
-     unquote-splicing? if
-         eval-unquote ( cdritems caritem )
- 
-         2swap nil? if
-             2drop
-         else
-             2swap join-lists
-         then
-     else
-         eval-quasiquote-item ( cdritems caritem )
-         2swap cons
-     then
- 
- ;
- 
- :noname ( env obj )
-     nil? if
-         2swap 2drop exit
-     then
- 
-     unquote? if
-         eval-unquote exit
-     then
- 
-     pair-type istype? if
-         eval-quasiquote-pair exit
-     then
- 
-     2swap 2drop
- ; is eval-quasiquote-item
- 
- : eval-quasiquote ( obj env -- res )
-     2swap cdr ( env args )
- 
-     nil? if
-         except-message: ." no arguments to quasiquote." recoverable-exception throw
-     then
- 
-     2dup cdr ( env args args-cdr )
-     nil? false = if
-         except-message: ." too many arguments to quasiquote." recoverable-exception throw
-     then
- 
-     2drop car ( env arg )
- 
-     eval-quasiquote-item
- ;
- 
  : variable? ( obj -- obj bool )
      symbol-type istype? ;
  
@@@ -1665,11 -1570,6 +1576,6 @@@ hide en
          exit
      then
  
-     quasiquote? if
-         2swap eval-quasiquote
-         exit
-     then
- 
      variable? if
          2swap lookup-var
          exit
@@@ -1732,270 -1632,6 +1638,270 @@@
  
  \ }}}
  
 +\ ---- Analyze ----
 +
 +: evaluate-eproc ( eproc env --- res )
 +
 +    >R >R
 +
 +    begin
 +        nil? invert
 +    while
 +        2dup car
 +        2swap cdr
 +    repeat
 +    
 +    2drop \ get rid of null
 +
 +    R> R> 2swap
 +
 +    \ Final element of eproc list is primitive procedure
 +    drop \ dump type signifier
 +
 +    .s cr \ DEBUG
 +
 +    goto \ jump straight to primitive procedure (executor)
 +;
 +
 +: self-evaluating-executor ( exp env -- exp )
 +    2drop ;
 +
 +: analyze-self-evaluating ( exp --- eproc )
 +    ['] self-evaluating-executor primitive-proc-type
 +    nil cons cons
 +;
 +
 +: quote-executor ( exp env -- exp )
 +    2drop ;
 +
 +: analyze-quoted ( exp -- eproc )
 +    quote-body
 +
 +    ['] quote-executor primitive-proc-type
 +    nil cons cons
 +;
 +
 +: variable-executor ( var env -- val )
 +    lookup-var ;
 +
 +: analyze-variable ( exp -- eproc )
 +    ['] variable-executor primitive-proc-type
 +    nil cons cons
 +;
 +
 +: definition-executor ( var val-eproc env -- ok )
 +    2swap 2over ( var env val-eproc env )
 +    evaluate-eproc 2swap ( var val env )
 +    define-var
 +    ok-symbol
 +;
 +
 +: analyze-definition ( exp -- eproc )
 +    2dup definition-var
 +    2swap definition-val analyze
 +
 +    ['] definition-executor primitive-proc-type
 +    nil cons cons cons
 +;
 +
 +: assignment-executor ( var val-eproc env -- ok )
 +    2swap 2over ( var env val-eproc env )
 +    evaluate-eproc 2swap ( var val env )
 +    set-var
 +    ok-symbol
 +;
 +
 +: analyze-assignment ( exp -- eproc )
 +    2dup assignment-var
 +    2swap assignment-val analyze ( var val-eproc )
 +
 +    ['] assignment-executor primitive-proc-type
 +    nil cons cons cons
 +;
 +
 +: if-executor ( cproc aproc pproc env -- res )
 +    2swap 2over ( cproc aproc env pproc env -- res )
 +    evaluate-eproc
 +
 +    true? if
 +        2swap 2drop
 +    else
 +        2rot 2drop
 +    then
 +
 +    evaluate-eproc
 +;
 +
 +: analyze-if ( exp -- eproc )
 +    2dup if-predicate analyze
 +    2swap 2dup if-consequent analyze
 +    2swap if-alternative analyze
 +
 +    ['] if-executor primitive-proc-type
 +    nil cons cons cons cons
 +;
 +
 +: sequence-executor ( eproc-list env -- res )
 +    2swap
 +
 +    begin
 +        2dup cdr ( env elist elist-rest)
 +        nil? invert
 +    while
 +
 +        -2rot car 2over ( elist-rest env elist-head env )
 +        evaluate-eproc  ( elist-rest env head-res )
 +        2drop 2swap     ( env elist-rest )
 +    repeat
 +
 +    2drop car 2swap
 +    ['] evaluate-eproc goto
 +;
 +
 +
 +: (analyze-sequence) ( explist -- eproc-list )
 +    nil? if exit then
 +
 +    2dup car analyze
 +    2swap cdr recurse
 +
 +    cons
 +;
 +
 +: analyze-sequence ( explist -- eproc )
 +    (analyze-sequence)
 +    ['] sequence-executor primitive-proc-type
 +    nil cons cons
 +;
 +
 +: lambda-executor ( params bproc env -- res )
 +    make-procedure
 +    ( Although this is packaged up as a regular compound procedure,
 +      the "body" element contains an _eproc_ to be evaluated in an
 +      environment resulting from extending env with the parameter
 +      bindings. )
 +;
 +
 +: analyze-lambda ( exp -- eproc )
 +    2dup lambda-parameters
 +    2swap lambda-body
 +
 +    nil? if
 +        except-message: ." encountered lambda with an empty body." recoverable-exception throw
 +    then
 +
 +    analyze-sequence
 +
 +    ['] lambda-executor primitive-proc-type
 +    nil cons cons cons
 +;
 +
 +: operand-eproc-list ( operands -- eprocs )
 +    nil? invert if
 +        2dup car analyze
 +        2swap cdr recurse
 +        cons
 +    then
 +;
 +
 +: evaluate-operand-eprocs ( env aprocs -- vals )
 +    nil? if
 +        2swap 2drop
 +    else
 +        2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
 +        -2rot cdr recurse ( thisval restvals )
 +        cons
 +    then
 +;
 +
 +: application-executor ( operator-proc arg-procs env -- res )
 +    2rot 2over ( aprocs env fproc env )
 +    evaluate-eproc ( aprocs env proc )
 +
 +    -2rot 2swap ( proc env aprocs )
 +    evaluate-operand-eprocs ( proc vals )
 +
 +    2swap ( vals proc )
 +    
 +    dup case
 +        primitive-proc-type of
 +            drop execute
 +        endof
 +
 +        compound-proc-type of
 +                2dup procedure-body ( argvals proc body )
 +                -2rot 2dup procedure-params ( bproc argvals proc argnames )
 +                -2rot procedure-env ( bproc argnames argvals procenv )
 +
 +                -2rot 2swap
 +                flatten-proc-args
 +                2swap 2rot
 +
 +                extend-env ( bproc env )
 +
 +               ['] evaluate-eproc goto
 +        endof
 +
 +        except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
 +    endcase
 +;
 +
 +: analyze-application ( exp -- eproc )
 +    2dup operator analyze
 +    2swap operands operand-eproc-list
 +
 +    ['] application-executor primitive-proc-type
 +    nil cons cons cons
 +;
 +
 +:noname ( exp --- eproc )
 +
 +    self-evaluating? if
 +        analyze-self-evaluating
 +        exit
 +    then
 +
 +    quote? if
 +        analyze-quoted
 +        exit
 +    then
 +    
 +    variable? if
 +        analyze-variable
 +        exit
 +    then
 +
 +    definition? if
 +        analyze-definition
 +        exit
 +    then
 +
 +    assignment? if
 +        analyze-assignment
 +        exit
 +    then
 +
 +    if? if
 +        analyze-if
 +        exit
 +    then
 +
 +    lambda? if
 +        analyze-lambda
 +        exit
 +    then
 +
 +    application? if
 +        analyze-application
 +        exit
 +    then
 +
 +    
 +    except-message: ." tried to analyze unknown expression type." recoverable-exception throw
 +
 +; is analyze
 +
 +
  \ ---- Macro Expansion ---- {{{
  
  ( Simply evaluates the given procedure with expbody as its argument. )
@@@ -2030,33 -1666,6 +1936,6 @@@
      R> drop ['] expand goto-deferred
  ;
  
- : expand-quasiquote-item ( exp -- result )
-     nil? if exit then
- 
-     unquote? if
-         unquote-symbol 2swap cdr car expand nil cons cons
-         exit
-     then
- 
-     unquote-splicing? if
-         unquote-splicing-symbol 2swap cdr car expand nil cons cons
-         exit
-     then
-     
-     pair-type istype? if
-         2dup car recurse
-         2swap cdr recurse
-         cons
-     then
- ;
- 
- : expand-quasiquote ( exp -- result )
-     quasiquote-symbol 2swap cdr
- 
-     expand-quasiquote-item
- 
-     cons ;
- 
  : expand-definition ( exp -- result )
      define-symbol 2swap
  
@@@ -2126,8 -1735,6 +2005,6 @@@
  
      quote? if exit then
  
-     quasiquote? if expand-quasiquote exit then
- 
      definition? if expand-definition exit then
  
      assignment? if expand-assignment exit then
@@@ -2380,7 -1987,7 +2257,7 @@@ variable gc-stack-dept
  
      include scheme-primitives.4th
  
 -    s" scheme-library.scm" load 2drop
 +    \ s" scheme-library.scm" load 2drop
      
  \ }}}
  
@@@ -2413,7 -2020,7 +2290,7 @@@
      enable-gc
  
      \ Display welcome message
 -    welcome-symbol nil cons global-env obj@ eval 2drop
 +    \ welcome-symbol nil cons global-env obj@ eval 2drop
  
      begin
          ['] repl-body catch