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 62db39c..a5a87e6 100644 (file)
--- 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 76979d2..dc5e97f 100644 (file)
--- 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 4bf44d4..d849946 100644 (file)
--- 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: [ ^'#<block>' ].
-        sexp class = Func ifTrue: [ ^'#<func>' ].
+        sexp type = #fn ifTrue: [ ^'#<fn>' ].
+        sexp type = #func ifTrue: [ ^'#<func>' ].
         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 138b967..8bb7adb 100644 (file)
--- 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 7ac7f1b..9341b86 100644 (file)
--- 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 8315042..758cc68 100644 (file)
--- 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 b1aa1f8..faeaf64 100644 (file)
--- 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 76f612f..69c7721 100644 (file)
--- 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 7b5f655..bd0e434 100644 (file)
--- 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 9f3b032..6e9a199 100644 (file)
--- 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 ]