[jackhill/mal.git] / forth / step8_macros.fs

require reader.fs
require printer.fs
require core.fs

core MalEnv. constant repl-env

99999999 constant TCO-eval

: read read-str ;
: eval ( env obj )
    begin
        \ ." eval-> " dup pr-str safe-type cr
        mal-eval
        dup TCO-eval =
    while
        drop
    repeat ;
: print
    \ ." Type: " dup mal-type @ type-name safe-type cr
    pr-str ;

MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself

MalKeyword
  extend eval-invoke { env list kw -- val }
    0   kw   env list MalList/start @ cell+ @ eval   get
    ?dup 0= if
        \ compute not-found value
        list MalList/count @ 1 > if
            env  list MalList/start @ 2 cells + @  TCO-eval
        else
            mal-nil
        endif
    endif ;;
drop

\ eval all but the first item of list
: eval-rest { env list -- argv argc }
    list MalList/start @ cell+ { expr-start }
    list MalList/count @ 1- { argc }
    argc cells allocate throw { target }
    argc 0 ?do
        env expr-start i cells + @ eval
        target i cells + !
    loop
    target argc ;

MalNativeFn
  extend eval-invoke { env list this -- list }
    env list eval-rest ( argv argc )
    this invoke ;;
  extend invoke ( argv argc this -- val )
    MalNativeFn/xt @ execute ;;
drop

SpecialOp
  extend eval-invoke ( env list this -- list )
    SpecialOp/xt @ execute ;;
drop

: install-special ( symbol xt )
    SpecialOp. repl-env env/set ;

: defspecial
    parse-allot-name MalSymbol.
    ['] install-special
    :noname
    ;

: is-pair? ( obj -- bool )
    empty? mal-false = ;

defspecial quote ( env list -- form )
    nip MalList/start @ cell+ @ ;;

s" concat" MalSymbol. constant concat-sym
s" cons" MalSymbol. constant cons-sym

defer quasiquote
: quasiquote0 { ast -- form }
    ast is-pair? 0= if
        here quote-sym , ast , here>MalList
    else
        ast to-list MalList/start @ { ast-start }
        ast-start @ { ast[0] }
        ast[0] unquote-sym m= if
            ast-start cell+ @
        else
            ast[0] is-pair? if
                ast[0] to-list MalList/start @ { ast[0]-start }
                ast[0]-start @ splice-unquote-sym m= if
                    here
                    concat-sym ,
                    ast[0]-start cell+ @ ,
                    ast to-list MalList/rest quasiquote ,
                    here>MalList
                    false
                else true endif
            else true endif
            if
                here
                cons-sym ,
                ast[0] quasiquote ,
                ast to-list MalList/rest quasiquote ,
                here>MalList
            endif
        endif
    endif ;
' quasiquote0 is quasiquote

defspecial quasiquote ( env list )
    MalList/start @ cell+ @ ( ast )
    quasiquote TCO-eval ;;

defspecial def! { env list -- val }
    list MalList/start @ cell+ { arg0 }
    arg0 @ ( key )
    env arg0 cell+ @ eval dup { val } ( key val )
    env env/set val ;;

defspecial defmacro! { env list -- val }
    list MalList/start @ cell+ { arg0 }
    arg0 @ ( key )
    env arg0 cell+ @ eval { val }
    true val MalUserFn/is-macro? !
    val env env/set
    val ;;

defspecial let* { old-env list -- val }
    old-env MalEnv. { env }
    list MalList/start @ cell+ dup { arg0 }
    @ to-list
    dup MalList/start @ { bindings-start } ( list )
    MalList/count @ 0 +do
        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
        env swap eval
        env env/set
    2 +loop
    env arg0 cell+ @ TCO-eval
    \ TODO: dec refcount of env
    ;;

defspecial do { env list -- val }
    list MalList/start @ { start }
    list MalList/count @ dup 1- { last } 1 ?do
        env   start i cells + @
        i last = if
            TCO-eval
        else
            eval drop
        endif
    loop ;;

defspecial if { env list -- val }
    list MalList/start @ cell+ { arg0 }
    env arg0 @ eval ( test-val )
    dup mal-false = if
        drop -1
    else
        mal-nil =
    endif
    if
        \ branch to false
        list MalList/count @ 3 > if
            env arg0 cell+ cell+ @ TCO-eval
        else
            mal-nil
        endif
    else
        \ branch to true
        env arg0 cell+ @ TCO-eval
    endif ;;

s" &" MalSymbol. constant &-sym

: new-user-fn-env { argv argc mal-fn -- env }
    mal-fn MalUserFn/formal-args @ { f-args-list }
    mal-fn MalUserFn/env @ MalEnv. { env }

    f-args-list MalList/start @ { f-args }
    f-args-list MalList/count @ ?dup 0= if else
        \ pass empty list for last arg, unless overridden below
        1- cells f-args + @ MalList new env env/set
    endif
    argc 0 ?do
        f-args i cells + @
        dup &-sym m= if
            drop
            argc i - { c }
            c cells allocate throw { start }
            argv i cells +  start  c cells  cmove
            f-args i 1+ cells + @ ( more-args-symbol )
            start c MalList. env env/set
            leave
        endif
        argv i cells + @
        env env/set
    loop
    env ;

MalUserFn
  extend eval-invoke { call-env list mal-fn -- list }
    mal-fn MalUserFn/is-macro? @ if
        list MalList/start @ cell+  \ argv
        list MalList/count @ 1-     \ argc
        mal-fn new-user-fn-env { env }
        env   mal-fn MalUserFn/body @   eval
        call-env swap TCO-eval
    else
        call-env list eval-rest
        mal-fn invoke
    endif ;;

  extend invoke ( argv argc mal-fn )
    dup { mal-fn } new-user-fn-env { env }
    env   mal-fn MalUserFn/body @   TCO-eval ;;
drop

defspecial fn* { env list -- val }
    list MalList/start @ cell+ { arg0 }
    MalUserFn new
    false over MalUserFn/is-macro? !
    env over MalUserFn/env !
    arg0 @ to-list over MalUserFn/formal-args !
    arg0 cell+ @ over MalUserFn/body ! ;;

defspecial macroexpand ( env list[_,form] -- form )
    MalList/start @ cell+ @ swap over ( form env form )
    MalList/start @ @ ( form env macro-name-expr )
    eval { macro-fn } ( form )
    dup MalList/start @ cell+  swap MalList/count @ 1- macro-fn ( argv argc fn )
    new-user-fn-env ( env )
    macro-fn MalUserFn/body @   TCO-eval ;;

MalSymbol
  extend mal-eval { env sym -- val }
    sym env env/get-addr
    dup 0= if
        drop
        0 0 s" ' not found" sym pr-str s" '" ...throw-str
    else
        @
    endif ;;
drop

: eval-ast { env list -- list }
    here
    list MalList/start @ { expr-start }
    list MalList/count @ 0 ?do
        env expr-start i cells + @ eval ,
    loop
    here>MalList ;

MalList
  extend mal-eval { env list -- val }
    list MalList/count @ 0= if
        list
    else
        env list MalList/start @ @ eval
        env list rot eval-invoke
    endif ;;
drop

MalVector
  extend mal-eval ( env vector -- vector )
    MalVector/list @ eval-ast
    MalVector new swap over MalVector/list ! ;;
drop

MalMap
  extend mal-eval ( env map -- map )
    MalMap/list @ eval-ast
    MalMap new swap over MalMap/list ! ;;
drop

defcore eval ( argv argc )
  drop @ repl-env swap eval ;;

: rep ( str-addr str-len -- str-addr str-len )
    read
    repl-env swap eval
    print ;

: mk-args-list ( -- )
    here
    begin
        next-arg 2dup 0 0 d<> while
            MalString. ,
    repeat
    2drop here>MalList ;

create buff 128 allot
77777777777 constant stack-leak-detect

: nop ;

defcore swap! { argv argc -- val }
    \ argv is  (atom fn args...)
    argv @ { atom }
    argv cell+ @ { fn }
    argc 1- { call-argc }
    call-argc cells allocate throw { call-argv }
    atom Atom/val   call-argv    1 cells   cmove
    argv cell+ cell+   call-argv cell+   call-argc 1- cells   cmove
    call-argv call-argc fn  invoke
    dup TCO-eval = if drop eval endif { new-val }
    new-val atom Atom/val !
    new-val ;;

s\" (def! not (fn* (x) (if x false true)))" rep 2drop
s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop
s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop

: repl ( -- )
    begin
      ." user> "
      stack-leak-detect
      buff 128 stdin read-line throw
    while ( num-bytes-read )
      dup 0 <> if
        buff swap ( str-addr str-len )
        ['] rep
        \ execute ['] nop \ uncomment to see stack traces
        catch ?dup 0= if
            safe-type cr
            stack-leak-detect <> if ." --stack leak--" cr endif
        else { errno }
            begin stack-leak-detect = until
            errno 1 <> if
                s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
                to exception-object
            endif
            ." Uncaught exception: "
            exception-object pr-str safe-type cr
        endif
      endif
    repeat ;

: main ( -- )
    mk-args-list { args-list }
    args-list MalList/count @ 0= if
        s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
        repl
    else
        args-list MalList/start @ @ { filename }
        s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set

        repl-env
        here s" load-file" MalSymbol. , filename , here>MalList
        eval print
    endif ;

main
cr
bye
Commit	Line	Data
e82947d0 C	1	require reader.fs
	2	require printer.fs
	3	require core.fs
	4
	5	core MalEnv. constant repl-env
	6
e82947d0 C	7	99999999 constant TCO-eval
	8
	9	: read read-str ;
	10	: eval ( env obj )
	11	begin
	12	\ ." eval-> " dup pr-str safe-type cr
	13	mal-eval
	14	dup TCO-eval =
	15	while
	16	drop
	17	repeat ;
	18	: print
	19	\ ." Type: " dup mal-type @ type-name safe-type cr
	20	pr-str ;
	21
	22	MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
	23
	24	MalKeyword
45c1894b	25	extend eval-invoke { env list kw -- val }
e82947d0 C	26	0 kw env list MalList/start @ cell+ @ eval get
	27	?dup 0= if
	28	\ compute not-found value
	29	list MalList/count @ 1 > if
	30	env list MalList/start @ 2 cells + @ TCO-eval
	31	else
	32	mal-nil
	33	endif
	34	endif ;;
	35	drop
	36
	37	\ eval all but the first item of list
	38	: eval-rest { env list -- argv argc }
	39	list MalList/start @ cell+ { expr-start }
	40	list MalList/count @ 1- { argc }
	41	argc cells allocate throw { target }
	42	argc 0 ?do
	43	env expr-start i cells + @ eval
	44	target i cells + !
	45	loop
	46	target argc ;
	47
	48	MalNativeFn
7148ddb6 DM	49	extend eval-invoke { env list this -- list }
	50	env list eval-rest ( argv argc )
	51	this invoke ;;
	52	extend invoke ( argv argc this -- val )
	53	MalNativeFn/xt @ execute ;;
e82947d0 C	54	drop
	55
	56	SpecialOp
45c1894b	57	extend eval-invoke ( env list this -- list )
e82947d0 C	58	SpecialOp/xt @ execute ;;
	59	drop
	60
	61	: install-special ( symbol xt )
	62	SpecialOp. repl-env env/set ;
	63
	64	: defspecial
	65	parse-allot-name MalSymbol.
	66	['] install-special
	67	:noname
	68	;
	69
	70	: is-pair? ( obj -- bool )
	71	empty? mal-false = ;
	72
	73	defspecial quote ( env list -- form )
	74	nip MalList/start @ cell+ @ ;;
	75
	76	s" concat" MalSymbol. constant concat-sym
	77	s" cons" MalSymbol. constant cons-sym
	78
	79	defer quasiquote
	80	: quasiquote0 { ast -- form }
	81	ast is-pair? 0= if
	82	here quote-sym , ast , here>MalList
	83	else
	84	ast to-list MalList/start @ { ast-start }
	85	ast-start @ { ast[0] }
	86	ast[0] unquote-sym m= if
	87	ast-start cell+ @
	88	else
	89	ast[0] is-pair? if
	90	ast[0] to-list MalList/start @ { ast[0]-start }
	91	ast[0]-start @ splice-unquote-sym m= if
	92	here
	93	concat-sym ,
	94	ast[0]-start cell+ @ ,
	95	ast to-list MalList/rest quasiquote ,
	96	here>MalList
	97	false
	98	else true endif
	99	else true endif
	100	if
	101	here
	102	cons-sym ,
	103	ast[0] quasiquote ,
	104	ast to-list MalList/rest quasiquote ,
	105	here>MalList
	106	endif
	107	endif
	108	endif ;
	109	' quasiquote0 is quasiquote
	110
	111	defspecial quasiquote ( env list )
	112	MalList/start @ cell+ @ ( ast )
	113	quasiquote TCO-eval ;;
	114
	115	defspecial def! { env list -- val }
	116	list MalList/start @ cell+ { arg0 }
	117	arg0 @ ( key )
	118	env arg0 cell+ @ eval dup { val } ( key val )
	119	env env/set val ;;
	120
	121	defspecial defmacro! { env list -- val }
122	list MalList/start @ cell+ { arg0 }
123	arg0 @ ( key )
124	env arg0 cell+ @ eval { val }
125	true val MalUserFn/is-macro? !
126	val env env/set
127	val ;;
128
129	defspecial let* { old-env list -- val }
130	old-env MalEnv. { env }
131	list MalList/start @ cell+ dup { arg0 }
132	@ to-list
133	dup MalList/start @ { bindings-start } ( list )
134	MalList/count @ 0 +do
135	bindings-start i cells + dup @ swap cell+ @ ( sym expr )
136	env swap eval
137	env env/set
138	2 +loop
139	env arg0 cell+ @ TCO-eval
140	\ TODO: dec refcount of env
141	;;
142
143	defspecial do { env list -- val }
144	list MalList/start @ { start }
145	list MalList/count @ dup 1- { last } 1 ?do
146	env start i cells + @
147	i last = if
148	TCO-eval
149	else
150	eval drop
151	endif
152	loop ;;
153
154	defspecial if { env list -- val }
155	list MalList/start @ cell+ { arg0 }
156	env arg0 @ eval ( test-val )
157	dup mal-false = if
158	drop -1
159	else
160	mal-nil =
161	endif
162	if
163	\ branch to false
164	list MalList/count @ 3 > if
165	env arg0 cell+ cell+ @ TCO-eval
166	else
167	mal-nil
168	endif
169	else
170	\ branch to true
171	env arg0 cell+ @ TCO-eval
172	endif ;;
173
174	s" &" MalSymbol. constant &-sym
175
176	: new-user-fn-env { argv argc mal-fn -- env }
177	mal-fn MalUserFn/formal-args @ { f-args-list }
178	mal-fn MalUserFn/env @ MalEnv. { env }
179
180	f-args-list MalList/start @ { f-args }
181	f-args-list MalList/count @ ?dup 0= if else
fe364a97 DM	182	\ pass empty list for last arg, unless overridden below
fe364a97 DM	183	1- cells f-args + @ MalList new env env/set
e82947d0 C	184	endif
	185	argc 0 ?do
	186	f-args i cells + @
	187	dup &-sym m= if
	188	drop
7148ddb6 DM	189	argc i - { c }
7148ddb6 DM	190	c cells allocate throw { start }
e82947d0	191	argv i cells + start c cells cmove
7148ddb6 DM	192	f-args i 1+ cells + @ ( more-args-symbol )
7148ddb6 DM	193	start c MalList. env env/set
e82947d0 C	194	leave
	195	endif
	196	argv i cells + @
	197	env env/set
	198	loop
	199	env ;
	200
	201	MalUserFn
45c1894b	202	extend eval-invoke { call-env list mal-fn -- list }
e82947d0	203	mal-fn MalUserFn/is-macro? @ if
7148ddb6 DM	204	list MalList/start @ cell+ \ argv
	205	list MalList/count @ 1- \ argc
	206	mal-fn new-user-fn-env { env }
e82947d0	207	env mal-fn MalUserFn/body @ eval
7148ddb6	208	call-env swap TCO-eval
e82947d0	209	else
7148ddb6 DM	210	call-env list eval-rest
7148ddb6 DM	211	mal-fn invoke
e82947d0	212	endif ;;
7148ddb6 DM	213
	214	extend invoke ( argv argc mal-fn )
	215	dup { mal-fn } new-user-fn-env { env }
	216	env mal-fn MalUserFn/body @ TCO-eval ;;
e82947d0 C	217	drop
	218
	219	defspecial fn* { env list -- val }
	220	list MalList/start @ cell+ { arg0 }
	221	MalUserFn new
7148ddb6	222	false over MalUserFn/is-macro? !
e82947d0 C	223	env over MalUserFn/env !
	224	arg0 @ to-list over MalUserFn/formal-args !
	225	arg0 cell+ @ over MalUserFn/body ! ;;
	226
	227	defspecial macroexpand ( env list[_,form] -- form )
	228	MalList/start @ cell+ @ swap over ( form env form )
	229	MalList/start @ @ ( form env macro-name-expr )
	230	eval { macro-fn } ( form )
	231	dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn )
	232	new-user-fn-env ( env )
	233	macro-fn MalUserFn/body @ TCO-eval ;;
	234
	235	MalSymbol
	236	extend mal-eval { env sym -- val }
a631063f	237	sym env env/get-addr
e82947d0 C	238	dup 0= if
e82947d0 C	239	drop
9e2a4ab0	240	0 0 s" ' not found" sym pr-str s" '" ...throw-str
a631063f C	241	else
a631063f C	242	@
e82947d0 C	243	endif ;;
	244	drop
	245
	246	: eval-ast { env list -- list }
	247	here
	248	list MalList/start @ { expr-start }
	249	list MalList/count @ 0 ?do
	250	env expr-start i cells + @ eval ,
	251	loop
	252	here>MalList ;
	253
	254	MalList
	255	extend mal-eval { env list -- val }
4e258d3a DM	256	list MalList/count @ 0= if
	257	list
	258	else
	259	env list MalList/start @ @ eval
	260	env list rot eval-invoke
	261	endif ;;
e82947d0 C	262	drop
	263
	264	MalVector
	265	extend mal-eval ( env vector -- vector )
	266	MalVector/list @ eval-ast
	267	MalVector new swap over MalVector/list ! ;;
	268	drop
	269
	270	MalMap
	271	extend mal-eval ( env map -- map )
	272	MalMap/list @ eval-ast
	273	MalMap new swap over MalMap/list ! ;;
	274	drop
	275
	276	defcore eval ( argv argc )
	277	drop @ repl-env swap eval ;;
	278
45c1894b	279	: rep ( str-addr str-len -- str-addr str-len )
e82947d0 C	280	read
	281	repl-env swap eval
	282	print ;
	283
	284	: mk-args-list ( -- )
	285	here
	286	begin
	287	next-arg 2dup 0 0 d<> while
	288	MalString. ,
	289	repeat
	290	2drop here>MalList ;
	291
e82947d0 C	292	create buff 128 allot
	293	77777777777 constant stack-leak-detect
	294
7148ddb6 DM	295	: nop ;
	296
	297	defcore swap! { argv argc -- val }
	298	\ argv is (atom fn args...)
	299	argv @ { atom }
	300	argv cell+ @ { fn }
	301	argc 1- { call-argc }
	302	call-argc cells allocate throw { call-argv }
	303	atom Atom/val call-argv 1 cells cmove
	304	argv cell+ cell+ call-argv cell+ call-argc 1- cells cmove
	305	call-argv call-argc fn invoke
	306	dup TCO-eval = if drop eval endif { new-val }
	307	new-val atom Atom/val !
	308	new-val ;;
	309
c5ea1323	310	s\" (def! not (fn* (x) (if x false true)))" rep 2drop
e6d41de4	311	s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop
45c1894b	312	s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop
45c1894b	313
e82947d0 C	314	: repl ( -- )
	315	begin
	316	." user> "
	317	stack-leak-detect
	318	buff 128 stdin read-line throw
	319	while ( num-bytes-read )
9e2a4ab0 JMC	320	dup 0 <> if
	321	buff swap ( str-addr str-len )
	322	['] rep
	323	\ execute ['] nop \ uncomment to see stack traces
	324	catch ?dup 0= if
	325	safe-type cr
	326	stack-leak-detect <> if ." --stack leak--" cr endif
	327	else { errno }
	328	begin stack-leak-detect = until
	329	errno 1 <> if
	330	s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
	331	to exception-object
	332	endif
	333	." Uncaught exception: "
	334	exception-object pr-str safe-type cr
	335	endif
	336	endif
e82947d0 C	337	repeat ;
	338
	339	: main ( -- )
	340	mk-args-list { args-list }
	341	args-list MalList/count @ 0= if
	342	s" ARGV" MalSymbol. MalList/Empty repl-env env/set
	343	repl
	344	else
	345	args-list MalList/start @ @ { filename }
	346	s" ARGV" MalSymbol. args-list MalList/rest repl-env env/set
	347
	348	repl-env
	349	here s" load-file" MalSymbol. , filename , here>MalList
	350	eval print
	351	endif ;
	352
	353	main
	354	cr
	355	bye