Changeset 27282 in project

Timestamp:

08/22/12 03:00:57 (9 years ago)

Author:

Ivan Raikov

Message:

miniML: some improvements on sxml representation of closures and functions, and roundtrip conversions of sxml <-> ir

Location:

release/4/miniML/trunk

Files:

• miniML.grm (modified) (4 diffs)
• miniML.l (modified) (1 diff)
• miniML.scm (modified) (1 diff)
• miniML.setup (modified) (1 diff)
• miniMLeval.scm (modified) (3 diffs)
• miniMLparse.scm (modified) (1 diff)
• miniMLvalue.scm (modified) (1 diff)

release/4/miniML/trunk/miniML.grm

@@ -39 +39 @@
           END EOF FUNCTOR 
           IF IN  LET  MODULE
-          RPAREN RBRACE SEMISEMI RETURN
+          SEMISEMI RETURN
           SIG STRUCT THEN TYPE VALUE
-          (left: COMMA DOT FUNCTION)
+          (left:  COMMA DOT FUNCTION)
           (left: LG LESS LEQ GREATER GEQ EQ EQUAL)
-          (left: PLUS MINUS STAR SLASH)
-          (right: ARROW)
-          (right: LPAREN LBRACE SEMICOLON COLON QUOTE POUND))
+          (left: PLUS MINUS STAR SLASH ARROW DARROW)
+          (right: LPAREN RPAREN LBRACE RBRACE SEMICOLON COLON QUOTE POUND)
+)
 
    ;; Toplevel entry point 
@@ -75 +75 @@
     (valexpr GREATER valexpr)           : (binop ">" $1 $3 )
     (valexpr GEQ valexpr)               : (binop ">=" $1 $3 )
-    (FUNCTION IDENT ARROW valexpr)      : (Function $2 $4)
+    (FUNCTION IDENT DARROW valexpr)      : (Function $2 $4)
     (LET IDENT valbind IN valexpr)      : (Let0 $2 $3 $5) 
     (IF valexpr THEN valexpr ELSE valexpr) : (ternop "cond" $2 $4 $6)
@@ -113 +113 @@
    (simpletype
     (QUOTE IDENT)                 : (Tvar (find-type-variable $2)) 
+    (LBRACE rfieldtypelist RBRACE) :  (let ((fs (sort $2 rfield-compare ))) 
+                                        (Tcon (Trec (map car fs)) (map cdr fs)))
     (simpletype ARROW simpletype) : (Tcon (Tpath path-arrow) (list $1 $3))
     (simpletype STAR simpletype)  : (Tcon (Tpath path-star) (list $1 $3))
@@ -118 +120 @@
     (simpletype path)             : (Tcon (Tpath $2) (list $1))
     (LPAREN simpletypelist RPAREN path) :  (Tcon (Tpath $4) (reverse $2))
-    (LBRACE rfieldtypelist RBRACE) :  (let ((fs (sort $2 rfield-compare ))) 
-                                        (Tcon (Trec (map car fs)) (map cdr fs)))
-                                              
     )
 

release/4/miniML/trunk/miniML.l

@@ -89 +89 @@
 ";;"                               (tok yyline SEMISEMI)
 "->"                               (tok yyline ARROW)
+"=>"                               (tok yyline DARROW)
 "="                                (tok yyline EQUAL)
 ","                                (tok yyline COMMA)

release/4/miniML/trunk/miniML.scm

@@ -945 +945 @@
             (let ((v (cadr c)))
               (cond ((boolean? v) (if v "true" "false"))
-                    ((number? v)  v)
                     (else (->string v)))))
       (else (error 'const->sxml "invalid constant" c))))

release/4/miniML/trunk/miniML.setup

@@ -4 +4 @@
   (make-pathname #f fn ##sys#load-dynamic-extension))   
 
-(define version 1.9)
+(define version 1.11)
 
 (use make)

release/4/miniML/trunk/miniMLeval.scm

@@ -176 +176 @@
   (Prim_v (lambda (xenv x)
             (let ((x (eval-closure (Closure_v x xenv))))
-              (Prim_v (lambda (yenv y) (op x (eval-closure (Closure_v y yenv)))))))))
+              (Prim_v (lambda (yenv y) 
+                        (let ((y (eval-closure (Closure_v y yenv))))
+                          (op x y))))
+              ))
+          ))
 
 
@@ -250 +254 @@
              "cons" 
              (prim-binop-cbv (eval-closure 'cons)
-              'cons (lambda (x y) (Tuple_v (cons x y)))))
+              'cons (lambda (x y) 
+                      (Tuple_v (cons x y)))))
         
             (enter-val
@@ -268 +273 @@
               (lambda (env x) 
                 (cases MLvalue (eval x env)
-                       (Tuple_v (p) (if (pair? p) (Tuple_v (cdr p))
-                                        (error 'tail "empty data element" x)))
+                       (Tuple_v (p) 
+                                (if (pair? p) (cdr p)
+                                    (error 'tail "empty data element" x)))
                        (else
                         (error 'tail "invalid data element" x))))))

release/4/miniML/trunk/miniMLparse.scm

@@ -59 +59 @@
       (cond  [(not arg) (error loc-str msg)]
              [(lexical-token? arg)
-              (error (conc "line " (source-location-line (lexical-token-source arg)) ": " msg) loc-str
+              (error (conc "line " (let ((src  (lexical-token-source arg)))
+                                     (if (source-location? src) 
+                                         (source-location-line src)
+                                         src))
+                           ": " msg) loc-str
                      (conc (lexical-token-category arg) 
                            (if (lexical-token-value arg) (conc " " (lexical-token-value arg)) "")))]

release/4/miniML/trunk/miniMLvalue.scm

@@ -63 +63 @@
                                  `(Closure ,body (,(car env) ...))))
                   (Prim_v (p) `(Prim ,p))
-                  (Tuple_v (d) `(Data ,d))
+                  (Tuple_v (d) `(Tuple ,d))
                   (Record_v (fs) `(Record ,fs))
                   )))