[jackhill/mal.git] / impls / gnu-smalltalk / stepA_mal.st

String extend [
    String >> loadRelative [
        | scriptPath scriptDirectory |
        scriptPath := thisContext currentFileName.
        scriptDirectory := FilePath stripFileNameFor: scriptPath.
        FileStream fileIn: (FilePath append: self to: scriptDirectory)
    ]
]

'readline.st' loadRelative.
'util.st' loadRelative.
'types.st' loadRelative.
'reader.st' loadRelative.
'printer.st' loadRelative.
'env.st' loadRelative.
'func.st' loadRelative.
'core.st' loadRelative.

Object subclass: MAL [
    MAL class >> READ: input [
        ^Reader readStr: input
    ]

    MAL class >> evalAst: sexp env: env [
        sexp type = #symbol ifTrue: [
            ^env get: sexp value
        ].

        sexp type = #list ifTrue: [
            ^self evalList: sexp env: env class: MALList
        ].
        sexp type = #vector ifTrue: [
            ^self evalList: sexp env: env class: MALVector
        ].
        sexp type = #map ifTrue: [
            ^self evalList: sexp env: env class: MALMap
        ].

        ^sexp
    ]

    MAL class >> evalList: sexp env: env class: aClass [
        | items |
        items := sexp value collect:
            [ :item | self EVAL: item env: env ].
        ^aClass new: items
    ]

    MAL class >> quasiquote: ast [
        | result a a0 a0_ a0_0 rest |
        ast isPair ifFalse: [
            result := {MALSymbol new: #quote. ast}.
            ^MALList new: (OrderedCollection from: result)
        ].

        a := ast value.
        a0 := a first.

        (a0 type = #symbol and: [ a0 value = #unquote ]) ifTrue: [ ^a second ].

        a0 isPair ifTrue: [
            a0_ := a0 value.
            a0_0 := a0_ first.

            (a0_0 type = #symbol and:
             [ a0_0 value = #'splice-unquote' ]) ifTrue: [
                rest := MALList new: a allButFirst.
                result := {MALSymbol new: #concat.
                           a0_ second.
                           self quasiquote: rest}.
                ^MALList new: (OrderedCollection from: result)
            ]
        ].

        rest := MALList new: a allButFirst.
        result := {MALSymbol new: #cons. self quasiquote: a0.
                   self quasiquote: rest}.
        ^MALList new: (OrderedCollection from: result)
    ]

    MAL class >> isMacroCall: ast env: env [
        | a0 a0_ f |
        ast type = #list ifTrue: [
            a0 := ast value first.
            a0_ := a0 value.
            a0 type = #symbol ifTrue: [
                f := env find: a0_.
                (f notNil and: [ f type = #func ]) ifTrue: [
                    ^f isMacro
                ]
            ]
        ].
        ^false
    ]

    MAL class >> macroexpand: aSexp env: env [
        | sexp |

        "NOTE: redefinition of method arguments is not allowed"
        sexp := aSexp.

        [ self isMacroCall: sexp env: env ] whileTrue: [
            | ast a0_ macro rest |
            ast := sexp value.
            a0_ := ast first value.
            macro := env find: a0_.
            rest := ast allButFirst.
            sexp := macro fn value: rest.
        ].

        ^sexp
    ]

    MAL class >> EVAL: aSexp env: anEnv [
        | sexp env ast a0 a0_ a1 a1_ a2 a2_ a3 forms function args |

        "NOTE: redefinition of method arguments is not allowed"
        sexp := aSexp.
        env := anEnv.

        [
            [ :continue |
                sexp type ~= #list ifTrue: [
                    ^self evalAst: sexp env: env
                ].
                sexp value isEmpty ifTrue: [
                    ^sexp
                ].

                sexp := self macroexpand: sexp env: env.
                sexp type ~= #list ifTrue: [
                    ^self evalAst: sexp env: env
                ].

                ast := sexp value.
                a0 := ast first.

                a0_ := ast first value.
                a0_ = #'def!' ifTrue: [
                    | result |
                    a1_ := ast second value.
                    a2 := ast third.
                    result := self EVAL: a2 env: env.
                    env set: a1_ value: result.
                    ^result
                ].

                a0_ = #'defmacro!' ifTrue: [
                    | result |
                    a1_ := ast second value.
                    a2 := ast third.
                    result := self EVAL: a2 env: env.
                    result isMacro: true.
                    env set: a1_ value: result.
                    ^result
                ].

                a0_ = #'macroexpand' ifTrue: [
                    a1 := ast second.
                    ^self macroexpand: a1 env: env
                ].

                a0_ = #'let*' ifTrue: [
                    | env_ |
                        env_ := Env new: env.
                    a1_ := ast second value.
                    a2 := ast third.
                    1 to: a1_ size by: 2 do:
                        [ :i | env_ set: (a1_ at: i) value
                                    value: (self EVAL: (a1_ at: i + 1)
                                                 env: env_) ].
                    env := env_.
                    sexp := a2.
                    continue value "TCO"
                ].

                a0_ = #do ifTrue: [
                    | forms last |
                    ast size < 2 ifTrue: [
                        forms := {}.
                        last := MALObject Nil.
                    ] ifFalse: [
                        forms := ast copyFrom: 2 to: ast size - 1.
                        last := ast last.
                    ].

                    forms do: [ :form | self EVAL: form env: env ].
                    sexp := last.
                    continue value "TCO"
                ].

                a0_ = #if ifTrue: [
                    | condition |
                    a1 := ast second.
                    a2 := ast third.
                    a3 := ast at: 4 ifAbsent: [ MALObject Nil ].
                    condition := self EVAL: a1 env: env.

                    (condition type = #false or:
                         [ condition type = #nil ]) ifTrue: [
                             sexp := a3
                         ] ifFalse: [
                             sexp := a2
                         ].
                    continue value "TCO"
                ].

                a0_ = #quote ifTrue: [
                    a1 := ast second.
                    ^a1
                ].

                a0_ = #quasiquote ifTrue: [
                    | result |
                    a1 := ast second.
                    sexp := self quasiquote: a1.
                    continue value "TCO"
                ].

                a0_ = #'try*' ifTrue: [
                    | A B C |
                    A := ast second.
                    ast at: 3 ifAbsent: [
                        ^self EVAL: A env: env.
                    ].
                    a2_ := ast third value.
                    B := a2_ second value.
                    C := a2_ third.
                    ^[ self EVAL: A env: env ] on: MALError do:
                        [ :err |
                            | data env_ result |
                            data := err data.
                            data isString ifTrue: [
                                data := MALString new: data
                            ].
                            env_ := Env new: env binds: {B} exprs: {data}.
                            err return: (self EVAL: C env: env_)
                        ]
                ].

                a0_ = #'fn*' ifTrue: [
                    | binds env_ fn |
                        a1_ := ast second value.
                    binds := a1_ collect: [ :item | item value ].
                    a2 := ast third.
                    fn := [ :args |
                        self EVAL: a2 env:
                            (Env new: env binds: binds exprs: args) ].
                    ^Func new: a2 params: binds env: env fn: fn
                ].

                forms := (self evalAst: sexp env: env) value.
                function := forms first.
                args := forms allButFirst asArray.

                function type = #fn ifTrue: [ ^function fn value: args ].
                function type = #func ifTrue: [
                    | env_ |
                    sexp := function ast.
                    env_ := Env new: function env binds: function params
                                exprs: args.
                    env := env_.
                    continue value "TCO"
                ]
            ] valueWithExit
        ] repeat.
    ]

    MAL class >> PRINT: sexp [
        ^Printer prStr: sexp printReadably: true
    ]

    MAL class >> rep: input env: env [
        ^self PRINT: (self EVAL: (self READ: input) env: env)
    ]
]

| input historyFile replEnv argv |

historyFile := '.mal_history'.
ReadLine readHistory: historyFile.
replEnv := Env new: nil.

argv := Smalltalk arguments.
argv notEmpty ifTrue: [ argv := argv allButFirst ].
argv := OrderedCollection from: (argv collect: [ :arg | MALString new: arg ]).

Core Ns keysAndValuesDo: [ :op :block | replEnv set: op value: block ].
replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]).
replEnv set: #'*ARGV*' value: (MALList new: argv).
replEnv set: #'*host-language*' value: (MALString new: 'smalltalk').

MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv.
MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv.
MAL rep: '(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)))))))' env: replEnv.

Smalltalk arguments notEmpty ifTrue: [
    MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv
] ifFalse: [
    MAL rep: '(println (str "Mal [" *host-language* "]"))' env: replEnv.
    [ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [
        input isEmpty ifFalse: [
            ReadLine addHistory: input.
            ReadLine writeHistory: historyFile.
            [ (MAL rep: input env: replEnv) displayNl ]
                on: MALEmptyInput do: [ #return ]
                on: MALError do:
                    [ :err | ('error: ', err messageText) displayNl. #return ].
        ]
    ].

    '' displayNl.
]
Commit	Line	Data
2aa83563 VS	1	String extend [
	2	String >> loadRelative [
	3	\| scriptPath scriptDirectory \|
999efc9f	4	scriptPath := thisContext currentFileName.
2aa83563 VS	5	scriptDirectory := FilePath stripFileNameFor: scriptPath.
	6	FileStream fileIn: (FilePath append: self to: scriptDirectory)
	7	]
	8	]
	9
	10	'readline.st' loadRelative.
	11	'util.st' loadRelative.
	12	'types.st' loadRelative.
	13	'reader.st' loadRelative.
	14	'printer.st' loadRelative.
	15	'env.st' loadRelative.
	16	'func.st' loadRelative.
	17	'core.st' loadRelative.
968e1a19 VS	18
	19	Object subclass: MAL [
	20	MAL class >> READ: input [
	21	^Reader readStr: input
	22	]
	23
	24	MAL class >> evalAst: sexp env: env [
	25	sexp type = #symbol ifTrue: [
	26	^env get: sexp value
	27	].
	28
	29	sexp type = #list ifTrue: [
	30	^self evalList: sexp env: env class: MALList
	31	].
	32	sexp type = #vector ifTrue: [
	33	^self evalList: sexp env: env class: MALVector
	34	].
	35	sexp type = #map ifTrue: [
	36	^self evalList: sexp env: env class: MALMap
	37	].
	38
	39	^sexp
	40	]
	41
	42	MAL class >> evalList: sexp env: env class: aClass [
	43	\| items \|
	44	items := sexp value collect:
	45	[ :item \| self EVAL: item env: env ].
	46	^aClass new: items
	47	]
	48
	49	MAL class >> quasiquote: ast [
06ecfc6a	50	\| result a a0 a0_ a0_0 rest \|
968e1a19 VS	51	ast isPair ifFalse: [
	52	result := {MALSymbol new: #quote. ast}.
	53	^MALList new: (OrderedCollection from: result)
	54	].
	55
	56	a := ast value.
	57	a0 := a first.
	58
	59	(a0 type = #symbol and: [ a0 value = #unquote ]) ifTrue: [ ^a second ].
	60
	61	a0 isPair ifTrue: [
	62	a0_ := a0 value.
	63	a0_0 := a0_ first.
968e1a19 VS	64
	65	(a0_0 type = #symbol and:
	66	[ a0_0 value = #'splice-unquote' ]) ifTrue: [
	67	rest := MALList new: a allButFirst.
06ecfc6a VS	68	result := {MALSymbol new: #concat.
06ecfc6a VS	69	a0_ second.
968e1a19 VS	70	self quasiquote: rest}.
	71	^MALList new: (OrderedCollection from: result)
	72	]
	73	].
	74
	75	rest := MALList new: a allButFirst.
	76	result := {MALSymbol new: #cons. self quasiquote: a0.
	77	self quasiquote: rest}.
	78	^MALList new: (OrderedCollection from: result)
	79	]
	80
	81	MAL class >> isMacroCall: ast env: env [
	82	\| a0 a0_ f \|
	83	ast type = #list ifTrue: [
	84	a0 := ast value first.
	85	a0_ := a0 value.
	86	a0 type = #symbol ifTrue: [
	87	f := env find: a0_.
	88	(f notNil and: [ f type = #func ]) ifTrue: [
	89	^f isMacro
	90	]
	91	]
	92	].
	93	^false
	94	]
	95
	96	MAL class >> macroexpand: aSexp env: env [
	97	\| sexp \|
	98
	99	"NOTE: redefinition of method arguments is not allowed"
	100	sexp := aSexp.
	101
	102	[ self isMacroCall: sexp env: env ] whileTrue: [
	103	\| ast a0_ macro rest \|
	104	ast := sexp value.
	105	a0_ := ast first value.
	106	macro := env find: a0_.
	107	rest := ast allButFirst.
	108	sexp := macro fn value: rest.
	109	].
	110
	111	^sexp
	112	]
	113
	114	MAL class >> EVAL: aSexp env: anEnv [
	115	\| sexp env ast a0 a0_ a1 a1_ a2 a2_ a3 forms function args \|
	116
	117	"NOTE: redefinition of method arguments is not allowed"
	118	sexp := aSexp.
	119	env := anEnv.
	120
	121	[
	122	[ :continue \|
	123	sexp type ~= #list ifTrue: [
	124	^self evalAst: sexp env: env
	125	].
	126	sexp value isEmpty ifTrue: [
	127	^sexp
	128	].
	129
	130	sexp := self macroexpand: sexp env: env.
	131	sexp type ~= #list ifTrue: [
	132	^self evalAst: sexp env: env
	133	].
134
135	ast := sexp value.
136	a0 := ast first.
137
138	a0_ := ast first value.
139	a0_ = #'def!' ifTrue: [
140	\| result \|
141	a1_ := ast second value.
142	a2 := ast third.
143	result := self EVAL: a2 env: env.
144	env set: a1_ value: result.
145	^result
146	].
147
148	a0_ = #'defmacro!' ifTrue: [
149	\| result \|
150	a1_ := ast second value.
151	a2 := ast third.
152	result := self EVAL: a2 env: env.
153	result isMacro: true.
154	env set: a1_ value: result.
155	^result
156	].
157
158	a0_ = #'macroexpand' ifTrue: [
159	a1 := ast second.
160	^self macroexpand: a1 env: env
161	].
162
163	a0_ = #'let*' ifTrue: [
164	\| env_ \|
165	env_ := Env new: env.
166	a1_ := ast second value.
167	a2 := ast third.
168	1 to: a1_ size by: 2 do:
169	[ :i \| env_ set: (a1_ at: i) value
170	value: (self EVAL: (a1_ at: i + 1)
171	env: env_) ].
172	env := env_.
173	sexp := a2.
174	continue value "TCO"
175	].
176
177	a0_ = #do ifTrue: [
178	\| forms last \|
179	ast size < 2 ifTrue: [
180	forms := {}.
181	last := MALObject Nil.
182	] ifFalse: [
183	forms := ast copyFrom: 2 to: ast size - 1.
184	last := ast last.
185	].
186
187	forms do: [ :form \| self EVAL: form env: env ].
188	sexp := last.
189	continue value "TCO"
190	].
191
192	a0_ = #if ifTrue: [
193	\| condition \|
194	a1 := ast second.
195	a2 := ast third.
196	a3 := ast at: 4 ifAbsent: [ MALObject Nil ].
197	condition := self EVAL: a1 env: env.
198
199	(condition type = #false or:
200	[ condition type = #nil ]) ifTrue: [
201	sexp := a3
202	] ifFalse: [
203	sexp := a2
204	].
205	continue value "TCO"
206	].
207
208	a0_ = #quote ifTrue: [
209	a1 := ast second.
210	^a1
211	].
212
213	a0_ = #quasiquote ifTrue: [
214	\| result \|
215	a1 := ast second.
216	sexp := self quasiquote: a1.
217	continue value "TCO"
218	].
219
220	a0_ = #'try*' ifTrue: [
221	\| A B C \|
222	A := ast second.
dd7a4f55 JM	223	ast at: 3 ifAbsent: [
	224	^self EVAL: A env: env.
	225	].
968e1a19 VS	226	a2_ := ast third value.
	227	B := a2_ second value.
	228	C := a2_ third.
	229	^[ self EVAL: A env: env ] on: MALError do:
	230	[ :err \|
	231	\| data env_ result \|
	232	data := err data.
	233	data isString ifTrue: [
	234	data := MALString new: data
	235	].
	236	env_ := Env new: env binds: {B} exprs: {data}.
	237	err return: (self EVAL: C env: env_)
	238	]
	239	].
	240
	241	a0_ = #'fn*' ifTrue: [
	242	\| binds env_ fn \|
	243	a1_ := ast second value.
	244	binds := a1_ collect: [ :item \| item value ].
	245	a2 := ast third.
	246	fn := [ :args \|
	247	self EVAL: a2 env:
	248	(Env new: env binds: binds exprs: args) ].
	249	^Func new: a2 params: binds env: env fn: fn
	250	].
	251
	252	forms := (self evalAst: sexp env: env) value.
	253	function := forms first.
	254	args := forms allButFirst asArray.
	255
	256	function type = #fn ifTrue: [ ^function fn value: args ].
	257	function type = #func ifTrue: [
	258	\| env_ \|
	259	sexp := function ast.
	260	env_ := Env new: function env binds: function params
	261	exprs: args.
	262	env := env_.
	263	continue value "TCO"
	264	]
	265	] valueWithExit
	266	] repeat.
	267	]
	268
	269	MAL class >> PRINT: sexp [
	270	^Printer prStr: sexp printReadably: true
	271	]
	272
	273	MAL class >> rep: input env: env [
	274	^self PRINT: (self EVAL: (self READ: input) env: env)
	275	]
	276	]
	277
	278	\| input historyFile replEnv argv \|
	279
	280	historyFile := '.mal_history'.
	281	ReadLine readHistory: historyFile.
	282	replEnv := Env new: nil.
	283
	284	argv := Smalltalk arguments.
	285	argv notEmpty ifTrue: [ argv := argv allButFirst ].
	286	argv := OrderedCollection from: (argv collect: [ :arg \| MALString new: arg ]).
	287
	288	Core Ns keysAndValuesDo: [ :op :block \| replEnv set: op value: block ].
	289	replEnv set: #eval value: (Fn new: [ :args \| MAL EVAL: args first env: replEnv ]).
290	replEnv set: #'ARGV' value: (MALList new: argv).
291	replEnv set: #'host-language' value: (MALString new: 'smalltalk').
292
293	MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv.
e6d41de4	294	MAL rep: '(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))' env: replEnv.
968e1a19	295	MAL rep: '(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)))))))' env: replEnv.
968e1a19 VS	296
	297	Smalltalk arguments notEmpty ifTrue: [
	298	MAL rep: '(load-file "', Smalltalk arguments first, '")' env: replEnv
	299	] ifFalse: [
	300	MAL rep: '(println (str "Mal [" host-language "]"))' env: replEnv.
	301	[ input := ReadLine readLine: 'user> '. input isNil ] whileFalse: [
	302	input isEmpty ifFalse: [
	303	ReadLine addHistory: input.
	304	ReadLine writeHistory: historyFile.
	305	[ (MAL rep: input env: replEnv) displayNl ]
	306	on: MALEmptyInput do: [ #return ]
	307	on: MALError do:
	308	[ :err \| ('error: ', err messageText) displayNl. #return ].
	309	]
	310	].
	311
	312	'' displayNl.
	313	]