claire 4.0.6 June 2022 release with many bug fixes

compile/goexp.cl

@@ -437,16 +437,16 @@ g_expression(self:Call_method,s:class) : void -> inline_exp(PRODUCER,self,s)
                  (m.selector = mClaire/nth_object))    // special case where we know the support (s1) of list a1
            let s1 := (if (m.selector = mClaire/nth_object) object 
                       else type_sort(g_member(a1))) in   // object or integer or float => type for values in list(a1); known by go compiler so no cast is necessary  
-              printf("~I~I.~I[~I-1]~I", cast_prefix(s1,s),
+              printf("~I~I.~I[~I]~I", cast_prefix(s1,s),
                      g_expression(a1,list), 
                      valuesSlot(g_member(a1)),
-                     g_expression(a2, integer), 
+                     at_index(a2), 
                      cast_post(s1,s))
         else if (((m = *nth_list* | m = *nth_tuple*) & compiler.safety >= 3) | 
                  (m = *nth_1_list* |  m = *nth_1_tuple* | m = *nth_1_array* ))     // use the .At method
-             printf("~I~I.At(~I-1)~I", cast_prefix(any,s),
+             printf("~I~I.At(~I)~I", cast_prefix(any,s),
                      g_expression(a1,list), 
-                     g_expression(a2, integer), 
+                     at_index(a2),                       // new in v4.0.6 
                      cast_post(any,s))
         else if (p = add! & domain!(m) <= bag)
            let sbag := (if (domain!(m) = set) set else list), %type := g_member(a1) in
@@ -483,9 +483,8 @@ g_expression(self:Call_method,s:class) : void -> inline_exp(PRODUCER,self,s)
 [inline_exp(c:go_producer,self:Call_method,s:class) : void
  -> let m := self.arg, a1 := self.args[1], a2 := self.args[2], a3 := self.args[3] in
        (if (m = *nth=_list* & compiler.safety >= 3 & g_member(a1) != any & s = void)
-           printf("~I.~I[~I-1]=~I", g_expression(a1,list),
-                  valuesSlot(g_member(a1)),
-                  g_expression(a2, integer), g_expression(a3, g_member(a1)),g_member(a1))
+           printf("~I.~I[~I]=~I", g_expression(a1,list),
+                  valuesSlot(g_member(a1)), at_index(a2), g_expression(a3, g_expected(g_member(a1))))
         else if (m = *nth_put_list* | m = *nth_put_array* | (compiler.safety >= 3 & m = *nth=_list*))
          printf("~I~I.NthPut(~I,~I)~I", cast_prefix(any,s), g_expression(a1,array),
                   g_expression(a2, integer), 
@@ -673,8 +672,8 @@ g_expression(self:Generate/C_cast,s:class) : void
          sm := g_member(self.selector) in
        (cast_prefix(sa,s),
         if (sm != any)
-            printf("~I.~I[~I - 1]",g_expression(self.selector, list), valuesSlot(sm), g_expression(self.arg, integer))
-        else printf("~I.At(~I - 1)",g_expression(self.selector, list), g_expression(self.arg, integer)),
+            printf("~I.~I[~I]",g_expression(self.selector, list), valuesSlot(sm), at_index(self.arg))
+        else printf("~I.At(~I)",g_expression(self.selector, list), at_index(self.arg)),
         cast_post(sa,s)) ]
 
 
@@ -702,7 +701,8 @@ sign_or(self:boolean) : void -> (if self princ("||") else princ("&&"))
 
 // default solution
 [bool_exp(self:any,pos?:boolean) : void 
-  -> printf("(~I ~I CTRUE)", g_expression(self, boolean), sign_equal(pos?)) ]
+  -> if (self = true) princ("true")    // v4.0.
+     else printf("(~I ~I CTRUE)", g_expression(self, boolean), sign_equal(pos?)) ]
 
 // strange : not clear why we should see a C_cast here
 [bool_exp(self:C_cast,pos?:boolean) : void 

compile/gogen.cl

@@ -241,7 +241,7 @@ c_string(c:go_producer, self:symbol) : string
 // statement to get rid of this
 // mode : 0 : normal no newline, 1 : newline, 2: special
 [var_declaration(v:string,s:class,mode:integer) : void
-  -> printf("var ~I ~I ~I", c_princ(v), interface!(s), (if (mode > 0) breakline())),
+  -> printf("var ~I ~I~I", c_princ(v), interface!(s), (if (mode > 0) breakline())),
      if (mode = 2) printf("_ = ~I~I",c_princ(v),breakline()) ]
 
 // ! is a semantic marker for imported
@@ -271,7 +271,7 @@ c_string(c:go_producer, self:symbol) : string
                                             else if (m2.module! = m.module! & c ^ m2.domain[1] != {})
                                                arg_match(go_signature(m2), %sig)
                                             else true), 
-                                    any true)))),
+                                    any defined(m.selector.name) = Kernel)))),        // v4.0.6: mix of methods & slot are not supported with Go
             any false)) ]
 
 
@@ -427,12 +427,12 @@ c_string(c:go_producer, self:symbol) : string
 // THERE are 5 sorts in go : int, float, char,  any (object) and EID
 // there are 7 sorts in CLAIRE : int, float, char, object, string, function, any
 [interface!(self:class) : void
- ->   if (self = void) princ("void ")
+ ->   if (self = void) princ("void")
       else if (self = integer) princ("int")
-       else if (self = float) princ("float64")
+      else if (self = float) princ("float64")
       else if (self = char)  princ("rune")
       else if (self = EID) princ("EID")
-      else  printf("*~I ", go_class(self))  ]
+      else  printf("*~I", go_class(self))  ]
 
 // general translation method: x is an expression that must be translated
 // to a CLAIRE object (*ClaireX). x is known to be functional ! s is the sort for x.
@@ -647,13 +647,17 @@ c_string(c:go_producer, self:symbol) : string
   -> if (x % Call_method | x % Construct | x % Variable | x % Call_slot | x % Cast | x % global_variable) 
         // g_sort(member(c_type(x))) //  is too  strong
         let t1 := (c_type(x) @ of) in
-          (if unique?(t1) the(t1) else any)
+          (if unique?(t1) class!(the(t1)) else any)
     else any ]
 
+// new : when g_member is x, what the the expected go_type 
+[g_expected(s:class) : class 
+  -> if (s = float | s = integer) s else any ]    
+
 // this is a way to access the low-level native slices (for list and sets)
-[cast_Values(sbag:class,gmem:class) : void 
-   ->  let short := (if (gmem = integer) "I" else if (gmem = float) "F" else "O") in
-          printf(".Values~A()",short) ]
+//[cast_Values(sbag:class,gmem:class) : void 
+//   ->  let short := (if (gmem = integer) "I" else if (gmem = float) "F" else "O") in
+//          printf(".Values~A()",short) ]
 
 // this method does nothing. It used to check if a name could create a naming conflict.
 // we keep it until we have tested that it is safe to remove it
@@ -678,3 +682,7 @@ build_Variable(s:string,t:any) : Variable
 [simple_func?(x:any) : boolean 
   -> if (g_clean(x) & c_type(x) != void) true
      else false ]
+
+// atIndex : print an integer "minus one"
+[at_index(x:any) : void
+  -> case x (integer princ(x - 1), any (g_expression(x, integer), princ("-1"))) ]

compile/gomain.cl

@@ -78,7 +78,7 @@
  (try
   (while (l)
    (case l[1]
-    ({"?", "-help"} printHelp(),
+    ({"?", "-help", "-h"} printHelp(),
      {"-q"} (vlevel := 0, l :<< 1),
      {"-v"} (vlevel := 2, l :<< 1),
      {"-s"}  (if (length(l) >= 2)  l :<< 2 else error("option: -s <s1> <s2>")),
@@ -266,15 +266,14 @@
 
 // create a directory for the module (if it does not exist)
 [compile_dir(m:module): void
- -> let s := "mkdir -p src" / capitalize(string!(m.name)) in 
-     (//[5] ask shell : ~S // s,
+ -> let s := "mkdir -p " /+ home() / "go/src" / capitalize(string!(m.name)) in 
+     (if (home() = "")  error("the environment variable CLAIRE_HOME is undefined\n"),
       shell(s))]
 
 // create the go
 [compile_exe(%out:string): void
- -> let s := "go build src" / %out /+ ".go" in 
-     (//[5] ask shell : ~S // s,
-      shell(s))]
+ -> let s := "go build " /+ home() / "go/src"  / %out /+ ".go" in 
+     (shell(s))]
 
 
 

compile/gostat.cl

@@ -290,8 +290,8 @@ unfold_eid(ldef:list,self:any,s:class, v:any,err:boolean,loop:any) : void
        let v2 := c_string(PRODUCER,self.var),  x := self.value,
            f := g_clean(x), try? := g_throw(x), ev := class!(self.var.range) in
               (let_block(),
-               var_declaration(v2,ev,0), 
-               if f printf(" = ~I", g_expression(x,ev)),
+               var_declaration(v2,ev,0),                    // no trailing " " in v4.0.6
+               if f printf(" = ~I", g_expression(x,ev)),    // 
                breakline(),
                // printf("/* noccur = ~A */~I",Language/occurexact(self.arg, self.var),breakline()),   // occurexact should discard setup !
                if (Language/occurexact(self.arg, self.var) < 1)          // avoid unused variable error (1 safe, 0 optimized)
@@ -520,9 +520,9 @@ unfold_eid(ldef:list,self:any,s:class, v:any,err:boolean,loop:any) : void
 // returns 1 if we use a try/pattern for error protection
 [iteration_statement(self:For,%set:any,sbag:class,smember:class,v:string,v3:string,v4:string) : integer
  -> if (g_clean(%set) & designated?(%set) & (smember != any & sbag = list))         // simple forms for list (%set is used once)
-          (printf("for _,~I = range(~I~I)~I", c_princ(v4),                           // typed list iteration pattern
+          (printf("for _,~I = range(~I.~I)~I", c_princ(v4),                           // typed list iteration pattern
                    g_expression(%set, sbag),                                        // notice that v4 occurs once
-                   cast_Values(sbag, smember),                                      // access through Values*()
+                   valuesSlot(smember),                                      // access through Values*()
                    new_block("loop")),
            0)
     else let try? := g_throw(%set) in
@@ -533,11 +533,11 @@ unfold_eid(ldef:list,self:any,s:class, v:any,err:boolean,loop:any) : void
                 printf("for i_it := 0; i_it < ~I.Count; i_it++ ~I~I",  c_princ(v3), 
                      new_block(),
                      (if (smember = integer | smember = float)
-                        printf("~I = ~I~I[i_it]~I", c_princ(v4), c_princ(v3),cast_Values(sbag, smember),breakline())
+                        printf("~I = ~I.~I[i_it]~I", c_princ(v4), c_princ(v3),valuesSlot(smember),breakline())
                       else printf("~I = ~I.At(i_it)~I", c_princ(v4), c_princ(v3),breakline())))
              else if (g_member(%set) != any)                                 // use native pattern for list
-                printf("for _,~I = range(~I~I)~I", c_princ(v4), c_princ(v3), 
-                         cast_Values(sbag, smember),
+                printf("for _,~I = range(~I.~I)~I", c_princ(v4), c_princ(v3), 
+                         valuesSlot(smember),
                          new_block("loop2"))
             else let v5 := c_string(PRODUCER,self.var) /+ "_len" in       // length of bag, used forregular pattern for complex list expr
               (printf("~I := ~I.Length()~I", c_princ(v5),c_princ(v3),breakline()),

compile/gosystem.cl

@@ -695,7 +695,7 @@ parents(self:list) : list
 // default complex case : create a variable "Result"
 [procedure_body(m:method, %l:lambda, %body:any,s:class) : void
   ->  if need_debug?(m) debug_intro(PRODUCER,%l,m),
-      printf("// procedure body with s = ~S~I",s,breakline()),
+      if PRODUCER.debug? printf("// procedure body, with s = ~S~I",s,breakline()),
       if (s != void) 
          (var_declaration("Result",s,1),
           statement(%body,s,"Result",false))
@@ -712,7 +712,7 @@ parents(self:list) : list
 // call for the debug/profile is needed     
 [eid_body(m:method,%body:any,typeOK:boolean, s:class) : void
  -> if need_debug?(m) debug_intro(PRODUCER,m.formula,m),
-    printf("// eid body s = ~S~I",s,breakline()),
+    if PRODUCER.debug? printf("// eid body s = ~S~I",s,breakline()),
     var_declaration("Result",EID,1),
     statement(%body,EID,"Result",g_throw(%body)),
     if need_debug?(m) return_result(PRODUCER,EID,m,"Result")

compile/odefine.cl

@@ -249,7 +249,7 @@ c_type(self:Defmethod) : type -> any
        (case %body (Call (%body.selector = sort &
                           (let a1 := %body.args[1] in
                              (case a1 (Call (a1.selector = @ & a1.args[1] % property)))) &
-                          lexical_build(%body.args[2],lv,0) = lv[1]),
+                          lexical_index(%body.args[2],lv,0,false) = lv[1]),
                     any false))) ]
 
 
@@ -382,7 +382,7 @@ compile_lambda(self:string,l:lambda,m:any) : any
         %v := (case %a (table %a, any error("[internal] the table ~S is unknown", a[1]))),
         s := %a.domain,
         e := (let l := cdr(a),
-                  b := Language/lexical_build(self.body, l, 0) in
+                  b := Language/lexical_index(self.body, l, 0, true) in
                 (if exists(va in l | Language/occurrence(b, va) > 0) lambda!(l, b)
                  else self.body)),
         d := (case e (lambda unknown, any self.body)),

compile/osystem.cl

@@ -123,7 +123,7 @@ claire/compiler :: meta_compiler(
    external = "go", // Id(compiler.external),
    env = "MacOS",   // Id(compiler.env),
    version = Id(version()),
-   source = "",
+   source = Id(home() / "go/src"),
    libraries = list<string>("Kernel"))
 
 // re-definable items for bootstrap modifications
@@ -177,7 +177,7 @@ Pattern <: type_expression(
 claire/OPT :: meta_OPT(
     outfile = stdin, 
     ignore = set(mClaire/index!, mClaire/set_index, object!, mClaire/base!, mClaire/set_base,
-                 mClaire/push!, anyObject!, mClaire/get_stack, mClaire/put_stack),
+                 mClaire/push!, anyObject!, mClaire/get_stack, mClaire/put_stack, main),
     to_remove = {},                                         // set(interface),
     knowns = set<relation>(arg1,arg2),                     // v3.1.12
     unsure = list(+ @ integer, * @ integer, - @ integer),
@@ -242,7 +242,7 @@ claire/safe(x:any) : type[x] -> x
       (if (s = void | z = s) //  | OPT.online?)
            (if (s = void & (case x (Call x.selector = =)))
                (warn(),
-                trace(2,"-- Equality meant as an assignment: ~S [264]\n",x)),    // v3.3
+                trace(1,"-- Equality meant as an assignment: ~S [264]\n",x)),    // v3.3
             y)       // v3.0.44 BIG CHANGE
       // else if (s = any)
       //   (if (z = integer & y % Call_slot &                       // need a proper slot

compile/otool.cl

@@ -122,8 +122,9 @@ Compile/notice() : void
 [c_warn(self:Call,%type:any) : any
  -> let s := self.selector in
        (if (%type = void)  Cerror("[205] message ~S sent to void object", self)
-        else if (not(s.restrictions) & not(s % OPT.ignore))
-           (warn(),trace(1,"the property ~S is undefined [255]\n", s))
+        else if (not(s.restrictions) & not(s % OPT.ignore) & s.open < open())
+           Cerror("[255] property ~S has no definition and is not defined as open", s)  // v4.0.6
+           // was:   (warn(),trace(1,"the property ~S is undefined [255]\n", s))
         else if (not(s % OPT.ignore) & (s.open <= 1 | s.open = 4) &
                  (case %type (list class!(%type[1]).open != 3)))
             (warn(), trace(1,"wrongly typed message ~S (~S) [256]\n", self, %type))

init.cl

@@ -3,20 +3,97 @@
 // Mac version
 *where* :: "/Users/ycaseau/claire/v4.0/go"                      // where the init file is
 *output* :: "/Users/ycaseau/claire/v4.0/go/src"
-*meta* :: "/Users/ycaseau/Dropbox/src/clairev4.03/src/meta"            // source files on dropbox (v2)
-*compile* :: "/Users/ycaseau/Dropbox/src/clairev4.03/src/compile"      // source files on dropbox (v2)
+*meta* :: "/Users/ycaseau/Dropbox/src/clairev4.05/src/meta"            // source files on dropbox (v2)
+*compile* :: "/Users/ycaseau/Dropbox/src/clairev4.05/src/compile"      // source files on dropbox (v2)
 *bsrc* :: "/Users/ycaseau/claire/v4.0/test/nonreg"
 *tsrc* :: "/Users/ycaseau/claire/v4.0/test/perf"
 *rsrc* :: "/Users/ycaseau/claire/v4.0/test/rules"
 
 // these are the global variables expected by the compiler
-RELEASE:float :: 0.05    // version of March 6th, 2022
-
+RELEASE:float :: 0.06    // version of March 11th, 2022
+
+// new in v4.0.6
+// atIndex : print an integer "minus one"
+[at_index(x:any) : void
+  -> case x (integer princ(x - 1), any (g_expression(x, integer), princ(" - 1"))) ]
+
+// additions
+/*
+begin(Core)
+[princ(s:string,n:integer) : void
+  -> let m := length(s) in
+       (if (m > n) princ(substring(s,1,n))
+        else (princ(s),
+              for i in (m + 1 .. n) princ(' '))) ] 
+end(Core)
+
+begin(Language)
+iClaire/lexical_index(self:any,lvar:list,n:integer,final?:boolean) : any
+ -> (if (self % thing | self % unbound_symbol) lexical_change(self, lvar)
+     else (case self
+            (Variable (if unknown?(index,self)                          // v3.1.12
+                          error("[145] the symbol ~A is unbound",  self.mClaire/pname),
+                       self),
+             Call let s := lexical_change(self.selector, lvar) in
+                    (lexical_index(self.args, lvar, n,final?),
+                     if (self.selector != s)
+                        (put(selector, self, call),
+                         put(args, self, s cons self.args))),
+             Instruction let %type:class := self.isa in
+                           (if (%type % Instruction_with_var.descendants)
+                               (put(index, self.var, n),
+                                n := n + 1,
+                                if (n > *variable_index*)
+                                   *variable_index* := n),
+                            for s in %type.slots
+                              let x := get(s, self) in
+                                (if ((x % thing | x % unbound_symbol) &
+                                     s.range = any)
+                                    put(s, self, lexical_change(x, lvar))
+                                 else lexical_index(x, lvar, n, final?)),
+                            if (%type = Assign & (self as Assign).var % unbound_symbol & final?)                // CLAIRE4
+                                error("[101] ~S is not a variable but a ~S", (self as Assign).var, owner((self as Assign).var))),             // moved from self_eval @ Assign
+             list let %n := length(self) in
+                   while (%n > 0)
+                     (let x := (nth@list(self, %n)) in
+                        (if (x % thing | x % unbound_symbol)
+                            nth=@list(self, %n, lexical_change(x, lvar))
+                         else lexical_index(x, lvar, n, final?)),
+                      %n :- 1),
+             any nil),
+           self))
+
+end(Language)   
+
+begin(Generate)
+[g_expected(s:class) : class 
+  -> if (s = float | s = integer) s else any ]  
+
+// debug
+[totul?(self:class,l:list) : any
+ ->  let lp := get_indexed(self),
+         n := length(lp) in
+       (if (length(l) = n - 1 & 
+            forall(i in (2 .. n) | selector(lp[i]) = (l[i - 1] as Call).args[1]) &          // args are passed in the proper order !
+            (self.open = default() | self Core/<=t exception) &
+            n <= 4 & forall(i in (2 .. n) | srange(lp[i]) % {any,integer}))
+         let %c:any := Call((if (length(l) = 0) mClaire/new! else anyObject!),
+                        self cons list{ c_code(x.args[2],any) | x in l}),  // v3.00.10
+             m := (close @ self) in
+           (if (length(l) = 0) %c := c_code(%c),
+            if m Call_method1(arg = m, args = list(%c)) else %c)
+        else false) ]
+
+end(Generate)
+*/
 
 // ***************************************************************************
 // *    Part 1: Modules & compiler environment                               *
 // ***************************************************************************
 
+// meta files are now the "official" github directory
+(for m in {Core,Language,Reader} source(m) := *meta*,
+ for m in {Optimize,Generate} source(m) := *compile*)
 
 // where we want to generate the go code
 (when c := get_value("compiler") in 

meta/control.cl

@@ -515,7 +515,7 @@ self_eval(self:Array) : any
 self_eval(self:Map) : map_set
   -> let m := map!(self.domain,self.of) in
        (for x in self.args
-          (case x (pair put(m,x.first,x.second),
+          (case x (pair put(m,eval(x.first),eval(x.second)),
                    any error("~S is not a pair, cannot be inserted in map ~S",x,m))),
         m)