version 4.0.5 - first regular commit

compile/goexp.cl

@@ -170,13 +170,15 @@ g_expression(self:symbol,s:class) : void
              cast_post(s2,s)))  ]
 
 // global_variables are CLAIRE objects
+// v4.0.4 : handle optimized variables (nativeVarG)
 [g_expression(self:global_variable,s:class) : void 
   ->  if (s = EID) to_eid(PRODUCER,self,object) 
       else if (self.range = {} & (self.value % integer | self.value % float | self.value = nil))
           g_expression(self.value,s)            // global constant inlining
-      else (object_prefix(any,s),
+      else let s2 := (if nativeVar?(self) getRange(self) else any) in
+           (cast_prefix(s2,s),
             globalVar(PRODUCER,self),
-            object_post(any,s)) ]
+            cast_post(s2,s)) ]
 
 // builds a set
 g_expression(self:Set,s:class) : void 
@@ -224,11 +226,11 @@ g_expression(self:list,s:class) : void
 // new in CLAIRE 4 !! compilation of lambda is OK but requires the reader (similar to macros)
 g_expression(self:lambda,s:class) : void
  -> (Optimize/legal?(Reader,self),
-     printf("~ICore.F_read_lambda(MakeString(\"lambda[(~I),~S]\"))~I",
-          cast_prefix(lambda,s),
+     printf("~ICore.F_read_lambda_string(MakeString(\"lambda[(~I),~S]\"))~I",
+          eid_prefix(s),
           Language/ppvariable(self.vars), 
           self.body,
-          cast_post(lambda,s)))
+          eid_post(s)))
 
 //**********************************************************************
 //*          Part 2: expression for messages                         *

compile/gogen.cl

@@ -75,6 +75,7 @@ GO_PRODUCER :: go_producer(
  // a list of interface
  Generate/interfaces = list(integer, "int", char, "rune", string, "string", float, "float64 "),
  kernel_methods = list<any>(// empty @ set, class! @ type, copy @ set, length @ bag,
+                             nth @ list, nth @ tuple,        // needed for compiling with low optimization
                              @ @ type,"At", array! @ list, // size @ set, empty @ bag, 
                              list! @ set, set! @ list, tuple! @ list,    // defined in Core (2nd order type)
                              list! @ tuple, /+ @ list,"Append", << @ list, "Skip")
@@ -198,7 +199,7 @@ c_string(c:go_producer, self:symbol) : string
 // range = {} for global constant
 [globalVar(c:go_producer,x:global_variable) : void
   ->  thing_ident(x),
-      princ(".Value") ]
+      if not(nativeVar?(x))  princ(".Value") ]         // do not forget optimized (native) global variables
 
 // the go expression that represents a global variable, as a string (reused for Gassign)
 

compile/gomain.cl

@@ -267,13 +267,13 @@
 // 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 
-     (//[0] ask shell : ~S // s,
+     (//[5] ask shell : ~S // s,
       shell(s))]
 
 // create the go
 [compile_exe(%out:string): void
  -> let s := "go build src" / %out /+ ".go" in 
-     (//[0] ask shell : ~S // s,
+     (//[5] ask shell : ~S // s,
       shell(s))]
 
 

compile/gostat.cl

@@ -283,6 +283,8 @@ unfold_eid(ldef:list,self:any,s:class, v:any,err:boolean,loop:any) : void
 // AXIOM if err is true, we require that e = any
 [g_statement(self:Let,e:class,v:string,err:boolean,loop:any) : void
   -> if let_eid?(self) g_eid_stat(self,e,v,err,loop)
+     else if (self.arg = self.var & e = void)        // stupid case where             
+         statement(self.value,e,v,loop)              // self.var is not needed !                          
      else let ns := c_string(PRODUCER,self.var.mClaire/pname) in
       (if (ns[1] = 'C' & ns[2] = '%') self.var.mClaire/pname := gensym(),     // used in Iterate (C% variables are expanded): ocontrol.cl
        let v2 := c_string(PRODUCER,self.var),  x := self.value,
@@ -295,7 +297,7 @@ unfold_eid(ldef:list,self:any,s:class, v:any,err:boolean,loop:any) : void
                if (Language/occurexact(self.arg, self.var) < 1)          // avoid unused variable error (1 safe, 0 optimized)
                   (// THIS SHOULD BE A PROPER WARNING ==============
                    //[5] >>>>>>>>  variable ~S declared but unused  // v2,          
-                   printf("_ = ~A~I", v2,breakline())),                    
+                   printf("_ = ~A~I", v2,breakline())),
                if  try? g_try(x,v2,ev,v,false)                           // if the value may be an error => start if chain
                else if not(f) statement(x, ev, v2,loop),
                statement(self.arg, e, v, loop),                          // calling statement is crictical for reintrant pattern :)
@@ -452,20 +454,22 @@ unfold_eid(ldef:list,self:any,s:class, v:any,err:boolean,loop:any) : void
 
 // This is the global variable assignment - global variables exist in go so this is pretty simple
 // note that the tricky part is the store management
+// v4.0.4 : if nativeVar, we need to produce the go object, not an any  (any is now replaced by %srange)
 [g_statement(self:Gassign,s:class,v:string,err:boolean,loop:any) : void
-   ->  let %var := self.var, x := self.arg  in
+   ->  let %var := self.var, x := self.arg, 
+           %range := (if nativeVar?(%var) getRange(%var) else any)  in
            (if (g_func(x) & s = void & not(%var.Kernel/store?))    // simple case
-               printf("~I = ~I~I", globalVar(PRODUCER,%var), g_expression(x,any), breakline())
+               printf("~I = ~I~I", globalVar(PRODUCER,%var), g_expression(x,%range), breakline())   
             else let v2 := genvar("v_gassign"), try? := g_throw(x) in
-              (if (not(try?) & (s = any)) v2 := v        // save intermediate the variable
-               else var_declaration(v2,any,1),
-               if try? g_try(x,v2,any,v,false)
-               else statement(x,any,v2,loop),
+              (if (not(try?) & (s = any & %range = any)) v2 := v        // save intermediate the variable
+               else var_declaration(v2,%range,1),
+               if try? g_try(x,v2,%range,v,false)
+               else statement(x,%range,v2,loop),
                if self.var.Kernel/store?  
                    printf("~I.StoreObj(3,~I,CTRUE)~I", thing_ident(%var), c_princ(v2),breakline())
                else printf("~I = ~I~I", globalVar(PRODUCER,%var), c_princ(v2),breakline()),
                if (s != void & v != v2) 
-                   printf("~I = ~I~I",c_princ(v),use_variable(v2,s,any),breakline()),
+                   printf("~I = ~I~I",c_princ(v),use_variable(v2,s,%range),breakline()),
                if try? close_block()))]
 
 

compile/gosystem.cl

@@ -656,11 +656,17 @@ parents(self:list) : list
 // generic case (g_func is true)
 
 // simpler case that we apply for Do, Ifs and functional expressions
+// however is c_type(exp) is void we need to return CNULL
 [function_body(self:any,s:class) : void
   -> let %ret := (if (s != void) "return " else "") in
-       (if (s = boolean)
-         printf("if ~I {return CTRUE~I} else {return CFALSE}",bool_exp(self,true),breakline())
-        else printf("~A ~I~I", %ret, g_expression(self,s),breakline())) ]
+//       (if (s = boolean)        // this is an old optimization that is USELESS in CLAIRE4
+//         printf("if ~I {return CTRUE~I} else {return CFALSE}",bool_exp(self,true),breakline())
+//        else printf("~A ~I~I", %ret, g_expression(self,s),breakline())) ]
+     (if (c_type(self) = void & s != void)
+         printf("~I~Ireturn ~I~I",
+                 g_expression(self,void), breakline(),
+                 g_expression(unknown,s), breakline())
+      else printf("~A ~I~I", %ret, g_expression(self,s),breakline())) ]
 
 // generate nice code for If function (inspired from g_statement@If)
 [function_body(self:If, s:class) : void

compile/ocontrol.cl

@@ -159,7 +159,7 @@ c_code(self:Call_function2) : any
        (if (length(a) = 1 & c_type(a[1]) <= integer)
           c_code(Call(write,list(verbose,system,a[1])))
         else if (length(a) > 1 & a[2] % string &
-                 (compiler.debug? | (try eval(a[1]) <= max(2,system.verbose) catch any true)))
+                 (compiler.debug? | (try eval(a[1]) <= max(3,system.verbose) catch any true)))
            let %c := Call(Core/tformat,
                           list(a[2], a[1], List(args = (copy(a) << 2)))) in
              c_code((if not(a[1] % integer)
@@ -215,7 +215,7 @@ c_type(self:Printf) : type -> any
                         else if ('I' = m) l[i]),
                      s := substring(s, n + 2, 1000),
                      n := get(s, '~')),
-                if s r :add Call(princ, list(s)),
+                if (length(s) > 0) r :add Call(princ, list(s)),
                 c_code(Do(r), any))) ]
 
 

compile/odefine.cl

@@ -99,7 +99,7 @@ c_code(self:Definition,s:class) : any
         else c_code(Let(var = %v,
                         value = Cast(arg = c_code(Call(mClaire/new!, list(%c)), object),
                                      set_arg = %c),
-                        arg = Do(args = analyze!(%c, %v, self.args, list()))),
+                        arg = Do!(analyze!(%c, %v, self.args, list()))),
                     s)))
 
 // tells if a "total instantiation" is appropriate (for exceptions)
@@ -151,21 +151,25 @@ c_code(self:Definition,s:class) : any
         r) ]
 
 // creation of a new named object
+// CLAIRE4 : native variable need a specific 
 c_code(self:Defobj,s:class) : any
- -> let %c := self.arg, o := value(self.Language/ident),
-        %v := (if (known?(o) & not(o % global_variable)) o
-               else Variable!(*name*, (OPT.max_vars :+ 1, 0), %c)),
-        %y1 := Call(object!, list(self.Language/ident, %c)),
-        %y2 := analyze!(%c, %v, self.args, list(name)),
-        %x:any := (if not(%v % Variable) Do(%y1 cons %y2)
-                   else  Let(var = %v, value = %y1, arg = Do(%y2))) in
-       (//[5] compile defobj(~S) -> ~S // self, o,
+ -> let %c := self.arg, o := value(self.Language/ident), %x:any := unknown in
+      (if (case o (global_variable nativeVar?(o)))
+          let %val := unknown in
+             (for c in self.args (if (case c (Call (c.selector = = & c.args[1] = value))) %val := c.args[2]),
+              %x :=  Gassign(var = o, arg = c_code(%val,class!(c_type(o)))))
+       else let  %v := (if (known?(o) & not(o % global_variable)) o
+                        else Variable!(*name*, (OPT.max_vars :+ 1, 0), %c)),
+                 %y1 := Call(object!, list(self.Language/ident, %c)),
+                 %y2 := analyze!(%c, %v, self.args, list(name)) in
+              (%x := (if not(%v % Variable) Do(%y1 cons %y2)
+                      else  Let(var = %v, value = %y1, arg = Do!(%y2))),
+               %x := c_code(%x, s)),
+        //[5] compile defobj(~S) -> ~S // self, o,
         if (%c.open <= 0) error("[105] cannot instantiate ~S", %c),          // v3.2.44
         if known?(o)
-           (if not(o % OPT.objects)
-               (OPT.objects :add o, c_register(o)))
+           (if not(o % OPT.objects) (OPT.objects :add o, c_register(o)))
         else (warn(),trace(2, "~S is unknown [265]\n", self.Language/ident)),
-        %x := c_code(%x, s),
         %x)
 
 // creation of a new named object
@@ -438,7 +442,7 @@ Compile/compute_if_write_inverse(R:relation) : void
             l1 :add Produce_put(R.inverse,y,x),
           R.if_write := lambda!(list(x,y),
                                 If(test = Call(not, list(Call(%, list(y,Produce_get(R,x))))),
-                                   arg = Do(l1))))
+                                   arg = Do!(l1))))
       else (//generate an if_write demon that does the put
             l1 := list<any>(Produce_put(R,x,y)),
             if known?(inverse,R)
@@ -449,7 +453,7 @@ Compile/compute_if_write_inverse(R:relation) : void
                                   Let(var = z,
                                       value = Produce_get(R,x),
                                       arg = If(test = Call(!=,list(y,z)),
-                                      arg = Do(l1))))),
+                                      arg = Do!(l1))))),
       let dn := string!(R.name) /+ "_write" in
           (Compile/compile_lambda(dn, R.if_write, void)))
 
@@ -467,7 +471,7 @@ Compile/compute_set_write(R:relation) : any
       l1 :add For(var = z, set_arg = y,
                   arg = Produce_put(R,x,z)),
       let dn := string!(R.name) /+ "_set_write" in
-          Compile/compile_lambda(dn, lambda!(list(x,y),Do(l1)), void))
+          Compile/compile_lambda(dn, lambda!(list(x,y),Do!(l1)), void))
 
 // generate a simple put for a property => generate a case to make sure
 // that we get the fastest possible code
@@ -584,7 +588,7 @@ c_code(self:Defrule,s:class) : any
         for r in Language/relations[ru]
           (if Language/eventMethod?(r)
               l :add compileEventMethod(r as property)),
-        c_code(Do(l), s))
+        c_code(Do!(l), s))
 
 // produce a beautiful if_write demon from all the claire demons created by each rule that applies to R
 [compile_if_write(R:relation) : void
@@ -605,7 +609,7 @@ c_code(self:Defrule,s:class) : any
          (if not(R.multivalued?) l1 :add Produce_remove(R.inverse,lvar[3],lvar[1]),
           l1 :add Produce_put(R.inverse,lvar[2],lvar[1])),
        R.if_write := lambda!( list(lvar[1],lvar[2]),
-         (if Language/eventMethod?(R) Do(l2)
+         (if Language/eventMethod?(R) Do!(l2)
           else if R.multivalued?
              If(test = Call(not,
                             list(Call(%,list(lvar[2],Language/readCall(R,lvar[1]))))),

compile/otool.cl

@@ -543,7 +543,9 @@ get_indexed(c:class) : list -> c.slots
         else if (tx <= list) c_code(Call(!=,list(Call(length,list(x)),0)))
         else c_code(Call(boolean!,list(x)))) ]
 
-
+// this should have been created long ago
+Compile/Do!(l:list) : any
+  -> (if (length(l) = 1) l[1] else Do(args = l))
 
 
 

init.cl

@@ -1,25 +1,22 @@
 (printf("Hello CLAIRE4, this is our init.cl file\n"))
 
 // Mac version
-*where* :: "/Users/ycaseau/claire/v4.0/go4"                      // where the init file is
-*output* :: "/Users/ycaseau/claire/v4.0/go4/src"
+*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)
 *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.04    // December 24th, 2021 
+RELEASE:float :: 0.05    // version of March 6th, 2022
+
 
 // ***************************************************************************
 // *    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 
@@ -164,6 +161,9 @@ mMonkey :: module( uses = list(Reader), source = *rsrc*,
 mZebra :: module( uses = list(Reader), source = *rsrc*,
                   made_of = list("zebra"))
 
+// airline - WIP (old CLAIRE 2 example)
+mAirline :: module( uses = list(Reader), source = *rsrc*,
+                  made_of = list("Airline"))
 
 // these are the old non-regression tests files (refreshed in July 2021)
 (printf("Done. \n"))

meta/call.cl

@@ -105,7 +105,8 @@ self_eval(self:Call*) : any
 printe(self:any,s:property) : void
  -> (if (case self
           (Call (self.selector % operation & length(self.args) = 2)))
-        (if true printf("(~S)", self) else printexp(self, true))
+         printf("(~S)", self)
+        // previous code (if true printf("(~S)", self) else printexp(self, true))
      else printexp(self, true))
 
 // tells if the sugar :op can be used

meta/define.cl

@@ -697,6 +697,7 @@ eventMethod(p:property) : void
                       jito(s),
                       jito(self.arg),
                       if o? put(range,v,unknown)),
+       While (jito(self.test), jito(self.arg)),
        Construct (trace(3,"-- Construct jito: ~S\n",self),
                   jito(self.args)),
        Exists (jito(self.iClaire/set_arg), jito(self.arg), jito(self.other)),

meta/function.cl

@@ -196,6 +196,7 @@ not(self:any) : boolean
       else if (self = false) true
       else if not(self) true         // catch special cases : empty list
       else false)
+
 !=(self:any,x:any) : boolean -> (if (self = x) false else true)
 
 // gives the type of any object. This is open_coded.
@@ -606,10 +607,11 @@ difference(self:set,x:set) : set -> { y in self | not(contain?(x, y))}
 
 //--------- ARRAY --------------------------------------------------------
 
+/* defined in Kernel in v4.0.5
 nth=(self:array,x:integer,y:any) : void
  -> (if not(y % of(self)) error("type mismatch for array update ~S, ~S",y,self)
      else if (x > 0 & x <= length(self)) nth_put(self,x,y)
-     else error("nth[~S] out of scope for ~S", x, self))
+     else error("nth[~S] out of scope for ~S", x, self)) */
 
 self_print(self:array) : void -> printf("array<~S>[~A]",of(self),length(self))
 

meta/method.cl

@@ -150,7 +150,7 @@ eval(self:any) : any -> eval(self)
      catch any unsafe(trace(0,"---- WARNING: inline definition of ~S is wrong\n", self)),
      self ]
 
-// reads a lambda
+// reads a lambda - may return an error
 [claire/read_lambda(s:string) : lambda
  -> try let p := read, l := call(p, s) in
           (case l (lambda l, any error("compiled lambda error with ~S (not a lambda!)",s)))

meta/types.cl

@@ -580,11 +580,12 @@ nth_arg_type(x:type,y:type) : type
 
 // we place here all methods that require second order types !!!!
 nth_get(a:array,n:integer) : type[member(a)] -> nth_get(a,n)                    // managed by cross-compiler ?
+/* v4.0.5 defined in Kernel
 nth(self:array,x:integer) : type[member(self)]
  -> (if (x > 0 & x <= length(self)) nth_get(self,x)
-     else error("[180] nth[~S] out of scope for ~S", x, self))
+     else error("[180] nth[~S] out of scope for ~S", x, self)) */
 make_array(i:integer,t:type,v:any) : type[ (if unique?(t) (the(t))[] else array)]
- -> function!(make_array_integer,NEW_ALLOC)
+ -> function!(make_array_integer)
 
 make_list(n:integer,t:type,x:any) : type[ (if unique?(t) list[the(t)] else list)]
   -> (cast!(make_list(n,x),t) as list) 
@@ -618,6 +619,7 @@ list!(l:set<X>) : type[(if (X = any) list else list<X>)]
  put(Kernel/typing, (new! @ list(class)), object_type_class),
  (nth_get @ array).Kernel/typing := first_member_type,
  (nth @ list).Kernel/typing := nth_arg_type, 
+ (nth @ array).Kernel/typing := nth_arg_type,     // v4.0.5
  (nth @ set).Kernel/typing := nth_arg_type,
  for r in nth+.restrictions (r as method).Kernel/typing := first_arg_type,
  for r in add.restrictions