3 files changed, 51 insertions(+), 42 deletions(-)

M fugue.janet
M test/fugue.janet
M test/namespaces.janet

@@ 27,21 27,21 @@
 # Bootstrapping
 #
 
-(defn- bare-proto
+(defn- base-proto
   "Basic prototype table."
-  [name defined-fields]
-  @{:_meta @{:object-type :prototype
+  [name defined-fields instance-defaults proto-allocated-fields & kvs]
+  (table
+    :_meta @{:object-type :prototype
              :fields defined-fields
-             :prototype-allocations @{}
-             :instance-defaults @{}
+             :prototype-allocations proto-allocated-fields
+             :instance-defaults instance-defaults
              :getters @{}}
-    :_name name})
+    :_name name
+    ;kvs))
 
 (def Root
   "Root of the Fugue object hierarchy."
-  (->
-    (bare-proto "Prototype" [])
-    (put :_init identity)))
+  (base-proto "Prototype" [] @{} @{} :_init identity))
 
 #
 # Field Access


@@ 109,7 109,7 @@
 (defn- field-definitions
   [name fields defined-fields]
   (let [field-definitions @{:init-args @[]
-                            :proto-allocated-fields @[]
+                            :proto-allocated-fields @{}
                             :proto-allocations @{}
                             :instance-defaults @{}
                             :getters @{}}]


@@ 124,7 124,7 @@
         (array/push (field-definitions :init-args) field-name))
       # Assemble fields that should be set directly on this prototype
       (when (= (attrs :allocation) :prototype)
-        (array/push (field-definitions :proto-allocated-fields) key-field))
+        (put-in field-definitions [:proto-allocated-fields key-field] true))
       # Assemble values to be set directly on prototype
       (when-let [proto-value (attrs :allocate-value)]
         (put-in field-definitions [:proto-allocations key-field] proto-value))


@@ 153,15 153,16 @@
    {:proto-allocated-fields proto-allocated-fields
     :proto-allocations to-allocate
     :instance-defaults instance-defaults}]
-  ~(let [object (,bare-proto (,string ',name) ,defined-fields)
-         parent (if (symbol? ',parent) ,parent ',Root)]
-     (,put-in object [:_meta :prototype-allocations]
-        (,table/setproto
-           (,table ;(,mapcat |[$0 object] ,proto-allocated-fields))
-           (,get-in parent [:_meta :prototype-allocations])))
-     (,put-in object [:_meta :instance-defaults] ,instance-defaults)
-     (,merge-into object ,to-allocate)
-     (,table/setproto object parent)))
+  ~(let [parent (if (symbol? ',parent) ,parent ',Root)]
+     (->
+       ',name
+       (,string)
+       (,base-proto
+          ,defined-fields
+          ,instance-defaults
+          ,proto-allocated-fields
+          ;(,kvs ,to-allocate))
+       (,table/setproto parent))))
 
 (defn- init-form
   "Generate the form that puts the object constructor method."


@@ 392,12 393,15 @@
   all descendents of that prototype.
   ```
   [obj key value]
-  (if-let [proto (table/getproto obj)
-           allocations (get-in proto [:_meta :prototype-allocations])
-           allocation (allocations key)
-           to-allocate allocation]
-    (put to-allocate key value)
-    (put obj key value)))
+  (var source-of-defaults obj)
+  (while source-of-defaults
+    (let [prototype-allocations (get-in source-of-defaults [:_meta :prototype-allocations])]
+      (if (and prototype-allocations (in prototype-allocations key)) (break))
+      # Recurse to grandparent
+      (set source-of-defaults (table/getproto source-of-defaults))))
+
+  (let [dest (or source-of-defaults obj)]
+    (put dest key value)))
 
 (def- raise-sentinel (gensym))
 


@@ 510,27 514,27 @@
 # Multimethod Closures
 #
 
-(def- var-cases @{})
+(def- multi-cases @{})
 
 (defn- set-multi-default
   [name]
-  (unless (dyn name)
-    (setdyn name {:private true :value @{}})))
+  (unless (in multi-cases name)
+    (put multi-cases name @{})))
 
 (defn- put-multi-case
-  [sym name types fun]
-  (let [multi-cases ((dyn sym) :value)]
-    (put-case name types fun multi-cases)))
+  [name types fun]
+  (put-case name types fun multi-cases))
 
 (defn- get-multi-cases
-  [sym name]
-  (let [multi-cases ((dyn sym) :value)]
-    (get-cases name multi-cases)))
+  [name]
+  (get-cases name multi-cases))
 
 #
 # Open Multi Closures
 #
 
+(def- var-cases @{})
+
 (defn- put-var-case
   [f types fun]
   (put-case f types fun var-cases))


@@ 683,13 687,14 @@
   ```
   ````
   [name multi-types args & body]
-
-  (let [cases-sym (symbol "_fugue-multi-cases-" name)]
-    (set-multi-default cases-sym)
-    (put-multi-case cases-sym name multi-types (make-case args body))
+  # Nominal case handling: group declared cases by concating the
+  # current file with the name of the function.
+  (let [cases-key (keyword (dyn :current-file) "-" name)]
+    (set-multi-default cases-key)
+    (put-multi-case cases-key multi-types (make-case args body))
 
     (with-syms [args]
-      (let [cases (get-multi-cases cases-sym name)
+      (let [cases (get-multi-cases cases-key)
             cond-form (construct-cond (string name) cases args)
             docstring (make-docstring cases)]
         (emit-defn name docstring args cond-form)))))

@@ 118,12 118,14 @@
 
 (fugue/defproto Editor () mode {:allocate-value "vi"})
 (fugue/defproto Light () speed {:allocate-value math/inf})
+(fugue/defproto Physics () light {:allocate-value Light})
 
 (deftest allocate-value
   (proto-tests Editor)
   (let [an-editor (:new Editor)
         another-editor (:new Editor)
-        some-light (:new Light)]
+        some-light (:new Light)
+        a-physics (:new Physics)]
     (inst-tests Editor an-editor)
     (fugue/allocate an-editor :mode "emacs")
     # The prototype has been allocated a value for `:mode`, which is


@@ 134,7 136,8 @@
     (is (= "emacs" (an-editor :mode)))
     (accessor-tests mode [an-editor another-editor Editor])
     (is (= :number (type (some-light :speed))))
-    (is (> (some-light :speed) 0))))
+    (is (> (some-light :speed) 0))
+    (is (= Light (a-physics :light)))))
 
 (fugue/defproto Dog ()
                 name {:allocate-value "Fido"}

@@ 19,6 19,7 @@
 
 (deftest overlapping-defmultis
   (is (= "ok!" (a/g "ok")))
+  # g was defined for strings in a, but not b.
   (is (thrown? (b/g "ok")))
   (is (= 12 (b/g 10))))