More review feedback

src/gerbil/runtime/c3.ss

@@ -41,23 +41,24 @@ namespace: #f
 ;; The main loop for c3
 ;; : (List X) (List (NonEmptyList X)) ?(X X -> Bool) ?(X -> Y) -> (List X)
 (def (c3-linearize-loop rhead tails (eqpred eqv?) (get-name identity))
-  (match tails
-    ([] (reverse rhead))
-    ([tail] (append-reverse rhead tail))
-    (else (let* ((err (cut error "Inconsistent precedence graph"
-                           head: (map get-name (reverse rhead))
-                           tails: (map (cut map get-name <>) tails)))
-                 (next (c3-select-next tails eqpred err)))
-            (c3-linearize-loop (cons next rhead)
-                               (remove-next! next tails eqpred)
-                               eqpred get-name)))))
+  (let loop ((rhead rhead) (tails tails))
+    (match tails
+      ([] (reverse rhead))
+      ([tail] (append-reverse rhead tail))
+      (else
+       (let* ((err (cut error "Inconsistent precedence graph"
+                        head: (map get-name (reverse rhead))
+                        tails: (map (cut map get-name <>) tails)))
+              (next (c3-select-next tails eqpred err)))
+         (loop (cons next rhead)
+               (remove-next! next tails eqpred)))))))
 
 ;; Next super selection loop, enforcing the ordering constraint and
 ;; otherwise implementing the earlier-in-list-first search heuristic.
 ;; : (NonEmptyList (NonEmptyList X)) ?(X X -> Bool) ?(-> Bottom) -> X
 (def (c3-select-next tails eqpred err)
   (let (candidate? ;; : X -> Bool
-        (lambda (c) (every/1 (lambda (tail) (not (member c (cdr tail) eqpred))) tails)))
+        (lambda (c) (andmap (lambda (tail) (not (member c (cdr tail) eqpred))) tails)))
     (let loop ((ts tails))
       (match ts
         ([[c . _] . rts]
@@ -105,18 +106,9 @@ namespace: #f
       l2)))
 
 ;; Append the reverse of the list in first argument and the list in second argument
-;; ~= (append (reverse rev-head) tail)
+;; = (append (reverse rev-head) tail) = (fold cons tail rev-head) ;; same as in SRFI 1.
 ;; : (List X) (List X) -> (List X)
 (def (append-reverse rev-head tail)
   (match rev-head
     ([hd . tl] (append-reverse tl (cons hd tail)))
     ([] tail)))
-
-;; True if every element in the list satisfies the predicate
-;; Simplified variant of every, not as general as the implementation in SRFI 1:
-;; it doesn't handle multiple lists, and doesn't return the last PRED value.
-;; : (X -> Bool) (List X) -> Bool
-(def (every/1 pred list)
-  (match list
-    ([x . r] (and (pred x) (every/1 pred r)))
-    (else #t)))

src/gerbil/runtime/mop.ss

@@ -31,7 +31,7 @@ namespace: #f
 ;;  6                 type-descriptor-mixin       :: (List TypeDescriptor)
 ;;  7                 type-descriptor-fields      :: Fixnum
 ;;  8                 type-descriptor-plist       :: AList (!)
-;;  9                 type-descriptor-ctor        :: Symbol
+;;  9                 type-descriptor-ctor        :: (OrFalse Symbol)
 ;; 10                 type-descriptor-slots       :: (Table (Or Symbol Keyword) -> Fixnum)
 ;; 11                 type-descriptor-methods     :: (Table Symbol -> Function)
 ;;
@@ -263,13 +263,16 @@ namespace: #f
 
 ;; Which is the most specific struct class if any that all argument classes are or inherit from?
 ;; : TypeDescriptor ... -> (OrFalse StructTypeDescriptor)
-(def (base-struct . all-supers)
+(def (base-struct/list all-supers)
   (match all-supers
     ([] #f)
     ([x] (base-struct/1 x))
     ([x y] (base-struct/2 x y))
     ([x y ...] (foldr base-struct/2 x y))))
 
+(def (base-struct . all-supers)
+  (base-struct/list all-supers))
+
 ;; Find the constructor method name for the TypeDescriptor
 ;; : (List TypeDescriptor) -> Symbol
 (def (find-super-ctor super)
@@ -325,16 +328,16 @@ namespace: #f
    ((find (lambda (klass) (assgetq final: (type-descriptor-plist klass))) super)
     => (cut error "Cannot extend final class" <>)))
 
-  (let*-values (((std-super) (apply base-struct super)) ;; super struct, if any
-                ((std-mixin) (class-linearize-mixins super))
-                ((std-fields field-list std-slots std-slot-list)
-                 (compute-class-slots std-super std-mixin slots))
-                ((std-plist)
-                 [[slots: . std-slot-list]
-                  (if std-super [[fields: . field-list]] [])...
-                  [direct-slots: . slots]
-                  plist ...])
-                ((std-ctor) (or ctor (find-super-ctor super))))
+  (let* ((std-super (base-struct/list super)) ;; super struct, if any
+         (std-mixin (class-linearize-mixins super))
+         ((values std-fields field-list std-slots std-slot-list)
+          (compute-class-slots std-super std-mixin slots))
+         (std-plist
+          [[slots: . std-slot-list]
+           (if std-super [[fields: . field-list]] [])...
+           [direct-slots: . slots]
+           plist ...])
+         (std-ctor (or ctor (find-super-ctor super))))
 
     (make-class-type-descriptor id name std-super std-mixin std-fields std-plist std-ctor std-slots)))
 
@@ -352,18 +355,15 @@ namespace: #f
 
 (def (make-class-predicate klass)
   (if (assgetq final: (type-descriptor-plist klass))
-    (lambda (obj)
-      (direct-class-instance? klass obj))
-    (lambda (obj)
-      (class-instance? klass obj))))
+    (cut direct-class-instance? klass <>)
+    (cut class-instance? klass <>)))
 
 (def (make-class-slot-accessor klass slot)
-  (lambda (obj)
-    (slot-ref obj slot)))
+  (cut slot-ref <> slot))
 
 (def (make-class-slot-mutator klass slot)
   (lambda (obj val)
-    (slot-set! obj slot val)))
+    (cut slot-set! obj slot val)))
 
 (def (make-class-slot-unchecked-accessor klass slot)
   (lambda (obj)