From: Vasilij Schneidermann Date: Sun, 9 Jul 2017 18:05:59 +0000 (+0200) Subject: Wrap BlockClosure into Fn to work around a bug X-Git-Url: https://git.hcoop.net/jackhill/mal.git/commitdiff_plain/aee373f32ec26c654896c401d5cab401761ed8d7 Wrap BlockClosure into Fn to work around a bug Extending a BlockClosure by a meta field gives a segfault for whatever reason. Yes, seriously. --- diff --git a/gst/core.st b/gst/core.st index 62db39cd..a5a87e63 100644 --- a/gst/core.st +++ b/gst/core.st @@ -28,90 +28,92 @@ Object subclass: Core [ ] Core Ns at: #+ put: - [ :args | MALNumber new: args first value + args second value ]. + (Fn new: [ :args | MALNumber new: args first value + args second value ]). Core Ns at: #- put: - [ :args | MALNumber new: args first value - args second value ]. + (Fn new: [ :args | MALNumber new: args first value - args second value ]). Core Ns at: #* put: - [ :args | MALNumber new: args first value * args second value ]. + (Fn new: [ :args | MALNumber new: args first value * args second value ]). Core Ns at: #/ put: - [ :args | MALNumber new: args first value // args second value ]. + (Fn new: [ :args | MALNumber new: args first value // args second value ]). Core Ns at: #'pr-str' put: - [ :args | MALString new: (Core printedArgs: args readable: true sep: ' ') ]. + (Fn new: [ :args | MALString new: (Core printedArgs: args readable: true + sep: ' ') ]). Core Ns at: #str put: - [ :args | MALString new: (Core printedArgs: args readable: false sep: '') ]. + (Fn new: [ :args | MALString new: (Core printedArgs: args readable: false + sep: '') ]). Core Ns at: #prn put: - [ :args | (Core printedArgs: args readable: true sep: ' ') displayNl. - MALObject Nil ]. + (Fn new: [ :args | + (Core printedArgs: args readable: true sep: ' ') displayNl. + MALObject Nil ]). Core Ns at: #println put: - [ :args | (Core printedArgs: args readable: false sep: ' ') displayNl. - MALObject Nil ]. + (Fn new: [ :args | + (Core printedArgs: args readable: false sep: ' ') displayNl. + MALObject Nil ]). -Core Ns at: #list put: [ :args | MALList new: (OrderedCollection from: args) ]. +Core Ns at: #list put: + (Fn new: [ :args | MALList new: (OrderedCollection from: args) ]). Core Ns at: #'list?' put: - [ :args | Core coerce: [ args first type = #list ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #list ] ]). Core Ns at: #'empty?' put: - [ :args | Core coerce: [ args first value isEmpty ] ]. + (Fn new: [ :args | Core coerce: [ args first value isEmpty ] ]). Core Ns at: #count put: - [ :args | MALNumber new: args first value size ]. + (Fn new: [ :args | MALNumber new: args first value size ]). Core Ns at: #= put: - [ :args | Core coerce: [ args first = args second ] ]. + (Fn new: [ :args | Core coerce: [ args first = args second ] ]). Core Ns at: #< put: - [ :args | Core coerce: [ args first value < args second value ] ]. + (Fn new: [ :args | Core coerce: [ args first value < args second value ] ]). Core Ns at: #<= put: - [ :args | Core coerce: [ args first value <= args second value ] ]. + (Fn new: [ :args | Core coerce: [ args first value <= args second value ] ]). Core Ns at: #> put: - [ :args | Core coerce: [ args first value > args second value ] ]. + (Fn new: [ :args | Core coerce: [ args first value > args second value ] ]). Core Ns at: #>= put: - [ :args | Core coerce: [ args first value >= args second value ] ]. + (Fn new: [ :args | Core coerce: [ args first value >= args second value ] ]). Core Ns at: #'read-string' put: - [ :args | Reader readStr: args first value ]. + (Fn new: [ :args | Reader readStr: args first value ]). Core Ns at: #slurp put: - [ :args | MALString new: (File path: args first value) contents ]. + (Fn new: [ :args | MALString new: (File path: args first value) contents ]). Core Ns at: #throw put: - [ :args | MALCustomError new signal: args first ]. + (Fn new: [ :args | MALCustomError new signal: args first ]). Core Ns at: #atom put: - [ :args | MALAtom new: args first ]. + (Fn new: [ :args | MALAtom new: args first ]). Core Ns at: #'atom?' put: - [ :args | Core coerce: [ args first type = #atom ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #atom ] ]). Core Ns at: #deref put: - [ :args | args first value ]. + (Fn new: [ :args | args first value ]). Core Ns at: #'reset!' put: - [ :args | args first value: args second. args second ]. + (Fn new: [ :args | args first value: args second. args second ]). Core Ns at: #'swap!' put: - [ :args | + (Fn new: [ :args | | a f x xs result | a := args first. - f := args second. - f class = Func ifTrue: [ f := f fn ]. + f := args second fn. x := a value. xs := args allButFirst: 2. result := f value: (xs copyWithFirst: x). a value: result. - result - ]. + result ]). Core Ns at: #cons put: - [ :args | MALList new: (args second value copyWithFirst: args first) ]. + (Fn new: [ :args | MALList new: (args second value copyWithFirst: args first) ]). Core Ns at: #concat put: - [ :args | MALList new: (OrderedCollection join: - (args collect: [ :arg | arg value ])) ]. + (Fn new: [ :args | MALList new: (OrderedCollection join: + (args collect: [ :arg | arg value ])) ]). Core Ns at: #nth put: - [ :args | + (Fn new: [ :args | | items index | items := args first value. index := args second value + 1. - items at: index ifAbsent: [ MALOutOfBounds new signal ] - ]. + items at: index ifAbsent: [ MALOutOfBounds new signal ] ]). Core Ns at: #first put: - [ :args | Core nilable: args else: [ - args first value at: 1 ifAbsent: [ MALObject Nil ] ] ]. + (Fn new: [ :args | Core nilable: args else: [ + args first value at: 1 ifAbsent: [ MALObject Nil ] ] ]). Core Ns at: #rest put: - [ :args | + (Fn new: [ :args | | items rest | items := args first value. (args first type = #nil or: [ items isEmpty ]) ifTrue: [ @@ -119,82 +121,75 @@ Core Ns at: #rest put: ] ifFalse: [ rest := items allButFirst ]. - MALList new: (OrderedCollection from: rest) - ]. + MALList new: (OrderedCollection from: rest) ]). Core Ns at: #apply put: - [ :args | + (Fn new: [ :args | | f rest result | - f := args first. - f class = Func ifTrue: [ f := f fn ]. + f := args first fn. args size < 3 ifTrue: [ rest := {} ] ifFalse: [ rest := args copyFrom: 2 to: args size - 1 ]. rest := rest, args last value. - f value: rest - ]. + f value: rest ]). Core Ns at: #map put: - [ :args | + (Fn new: [ :args | | items f result | - f := args first. - f class = Func ifTrue: [ f := f fn ]. + f := args first fn. items := args second value. result := items collect: [ :item | f value: {item} ]. - MALList new: (OrderedCollection from: result) - ]. + MALList new: (OrderedCollection from: result) ]). Core Ns at: #'nil?' put: - [ :args | Core coerce: [ args first type = #nil ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #nil ] ]). Core Ns at: #'true?' put: - [ :args | Core coerce: [ args first type = #true ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #true ] ]). Core Ns at: #'false?' put: - [ :args | Core coerce: [ args first type = #false ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #false ] ]). Core Ns at: #'symbol?' put: - [ :args | Core coerce: [ args first type = #symbol ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #symbol ] ]). Core Ns at: #'keyword?' put: - [ :args | Core coerce: [ args first type = #keyword ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #keyword ] ]). Core Ns at: #'vector?' put: - [ :args | Core coerce: [ args first type = #vector ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #vector ] ]). Core Ns at: #'map?' put: - [ :args | Core coerce: [ args first type = #map ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #map ] ]). Core Ns at: #'sequential?' put: - [ :args | Core coerce: [ args first type = #list or: - [ args first type = #vector ] ] ]. + (Fn new: [ :args | Core coerce: [ args first type = #list or: + [ args first type = #vector ] ] ]). Core Ns at: #symbol put: - [ :args | MALSymbol new: args first value asSymbol ]. + (Fn new: [ :args | MALSymbol new: args first value asSymbol ]). Core Ns at: #keyword put: - [ :args | MALKeyword new: args first value asSymbol ]. + (Fn new: [ :args | MALKeyword new: args first value asSymbol ]). Core Ns at: #vector put: - [ :args | MALVector new: (OrderedCollection from: args) ]. + (Fn new: [ :args | MALVector new: (OrderedCollection from: args) ]). Core Ns at: #'hash-map' put: - [ :args | MALMap new: args asDictionary ]. + (Fn new: [ :args | MALMap new: args asDictionary ]). Core Ns at: #assoc put: - [ :args | + (Fn new: [ :args | | result keyVals | result := Dictionary from: args first value associations. keyVals := args allButFirst. 1 to: keyVals size by: 2 do: [ :i | result add: (keyVals at: i) -> (keyVals at: i + 1) ]. - MALMap new: result - ]. + MALMap new: result ]). Core Ns at: #dissoc put: - [ :args | + (Fn new: [ :args | | result keys | result := Dictionary from: args first value associations. keys := args allButFirst. keys do: [ :key | result removeKey: key ifAbsent: [ nil ] ]. - MALMap new: result - ]. + MALMap new: result ]). Core Ns at: #get put: - [ :args | Core nilable: args else: - [ args first value at: args second ifAbsent: [ MALObject Nil ] ] ]. + (Fn new: [ :args | Core nilable: args else: + [ args first value at: args second ifAbsent: [ MALObject Nil ] ] ]). Core Ns at: #'contains?' put: - [ :args | Core coerce: [ args first value includesKey: args second ] ]. + (Fn new: [ :args | Core coerce: [ args first value includesKey: args second ] ]). Core Ns at: #keys put: - [ :args | MALList new: (OrderedCollection from: args first value keys) ]. + (Fn new: [ :args | MALList new: (OrderedCollection from: args first value keys) ]). Core Ns at: #vals put: - [ :args | MALList new: (OrderedCollection from: args first value values) ]. + (Fn new: [ :args | MALList new: (OrderedCollection from: args first value values) ]). diff --git a/gst/func.st b/gst/func.st index 76979d25..dc5e97fe 100644 --- a/gst/func.st +++ b/gst/func.st @@ -1,24 +1,19 @@ -Object subclass: Func [ - | ast params env fn isMacro meta | +MALObject subclass: Func [ + | ast params env fn isMacro | ast [ ^ast ] params [ ^params ] env [ ^env ] fn [ ^fn ] isMacro [ ^isMacro ] - meta [ ^meta ] isMacro: bool [ isMacro := bool ] - meta: aMeta [ - meta := aMeta - ] - Func class >> new: ast params: params env: env fn: fn [ | func | - func := super new. + func := super new: #func value: fn meta: nil. func init: ast params: params env: env fn: fn. ^func ] @@ -30,11 +25,4 @@ Object subclass: Func [ fn := aFn. isMacro := false ] - - withMeta: meta [ - | func | - func := self deepCopy. - func meta: meta. - ^func - ] ] diff --git a/gst/printer.st b/gst/printer.st index 4bf44d41..d8499465 100644 --- a/gst/printer.st +++ b/gst/printer.st @@ -2,8 +2,8 @@ FileStream fileIn: 'types.st'. Object subclass: Printer [ Printer class >> prStr: sexp printReadably: printReadably [ - sexp class = BlockClosure ifTrue: [ ^'#' ]. - sexp class = Func ifTrue: [ ^'#' ]. + sexp type = #fn ifTrue: [ ^'#' ]. + sexp type = #func ifTrue: [ ^'#' ]. sexp type = #true ifTrue: [ ^'true' ]. sexp type = #false ifTrue: [ ^'false' ]. sexp type = #nil ifTrue: [ ^'nil' ]. diff --git a/gst/step4_if_fn_do.st b/gst/step4_if_fn_do.st index 138b9678..8bb7adb5 100644 --- a/gst/step4_if_fn_do.st +++ b/gst/step4_if_fn_do.st @@ -89,12 +89,12 @@ Object subclass: MAL [ a1_ := ast second value. binds := a1_ collect: [ :item | item value ]. a2 := ast third. - ^[ :args | self EVAL: a2 env: + ^Fn new: [ :args | self EVAL: a2 env: (Env new: env binds: binds exprs: args) ] ]. forms := (self evalAst: sexp env: env) value. - function := forms first. + function := forms first fn. args := forms allButFirst asArray. ^function value: args ] diff --git a/gst/step5_tco.st b/gst/step5_tco.st index 7ac7f1bb..9341b86c 100644 --- a/gst/step5_tco.st +++ b/gst/step5_tco.st @@ -123,8 +123,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params diff --git a/gst/step6_file.st b/gst/step6_file.st index 8315042c..758cc68c 100644 --- a/gst/step6_file.st +++ b/gst/step6_file.st @@ -124,8 +124,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params @@ -157,7 +157,7 @@ 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: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). replEnv set: #'*ARGV*' value: (MALList new: argv). MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. diff --git a/gst/step7_quote.st b/gst/step7_quote.st index b1aa1f8d..faeaf645 100644 --- a/gst/step7_quote.st +++ b/gst/step7_quote.st @@ -168,8 +168,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params @@ -201,7 +201,7 @@ 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: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). replEnv set: #'*ARGV*' value: (MALList new: argv). MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. diff --git a/gst/step8_macros.st b/gst/step8_macros.st index 76f612f2..69c7721a 100644 --- a/gst/step8_macros.st +++ b/gst/step8_macros.st @@ -74,7 +74,7 @@ Object subclass: MAL [ a0_ := a0 value. a0 type = #symbol ifTrue: [ f := env find: a0_. - (f notNil and: [ f class = Func ]) ifTrue: [ + (f notNil and: [ f type = #func ]) ifTrue: [ ^f isMacro ] ] @@ -221,8 +221,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params @@ -254,7 +254,7 @@ 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: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). replEnv set: #'*ARGV*' value: (MALList new: argv). MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. diff --git a/gst/step9_try.st b/gst/step9_try.st index 7b5f6555..bd0e4342 100644 --- a/gst/step9_try.st +++ b/gst/step9_try.st @@ -74,7 +74,7 @@ Object subclass: MAL [ a0_ := a0 value. a0 type = #symbol ifTrue: [ f := env find: a0_. - (f notNil and: [ f class = Func ]) ifTrue: [ + (f notNil and: [ f type = #func ]) ifTrue: [ ^f isMacro ] ] @@ -239,8 +239,8 @@ Object subclass: MAL [ function := forms first. args := forms allButFirst asArray. - function class = BlockClosure ifTrue: [ ^function value: args ]. - function class = Func ifTrue: [ + function type = #fn ifTrue: [ ^function fn value: args ]. + function type = #func ifTrue: [ | env_ | sexp := function ast. env_ := Env new: function env binds: function params @@ -272,7 +272,7 @@ 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: [ :args | MAL EVAL: args first env: replEnv ]. +replEnv set: #eval value: (Fn new: [ :args | MAL EVAL: args first env: replEnv ]). replEnv set: #'*ARGV*' value: (MALList new: argv). MAL rep: '(def! not (fn* (a) (if a false true)))' env: replEnv. diff --git a/gst/types.st b/gst/types.st index 9f3b032a..6e9a1991 100644 --- a/gst/types.st +++ b/gst/types.st @@ -146,6 +146,23 @@ MALObject subclass: MALAtom [ ] ] +MALObject subclass: Fn [ + | fn | + + fn [ ^fn ] + + Fn class >> new: fn [ + | f | + f := super new: #fn value: fn meta: nil. + f init: fn. + ^f + ] + + init: f [ + fn := f. + ] +] + Error subclass: MALError [ description [ ^'A MAL-related error' ] isResumable [ ^true ]