Changes in hh2008/hayamiz/trunk/hascheme/parser.scm [23:15]

Files:

• hh2008/hayamiz/trunk/hascheme/parser.scm (modified) (9 diffs)

hh2008/hayamiz/trunk/hascheme/parser.scm

@@ -6 +6 @@
 (define-class <ast> () ())
 (define-class <ast-decl> (<ast>) ())
-(define-class <ast-decls> (<ast>)
-  ((delcs :init-keyword :decls :getter decls)))
 (define-class <ast-type-decl> (<ast-decl>)
   ((left :init-keyword :left :getter type-decl-left)
@@ -16 +14 @@
 (define-class <ast-single-type> (<ast-type>)
   ((type-name :init-keyword :name :getter type-name)
-   (type-arity :init-keyword :arity :accessor type-arity :init-value #f)
+   (type-arity :init-keyword :arity :accessor type-arity)
    (type-vars :init-keyword :vars :accessor type-vars :init-value #f)
    (type-module :init-keyword :module :getter type-module :init-value #f)))
 (define-class <ast-multi-type> (<ast-type>)
   ((types :init-keyword :name :accessor types)))
-(define-class <ast-simple-type> (<ast>)
-  ((type-name :init-keyword :name :getter type-name)
-   (type-vars :init-keyword :vars :getter type-vars)))
-
+(define-class <ast-simple-type> (<ast>) ())
 (define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>))
-  (make <ast-type-decl> :left left :right right))
+  ; (make <type-decl> :left left :right right)
+  `(:type-decl ,left ,right))
 
 (define (hascheme:parse str)
@@ -36 +32 @@
     (Body <- "{" (:decls TopDecls) "}" :return decls)
     (TopDecls <- Spaces* (:decl TopDecl) (:rest-decls TopDecls%) Spaces*
-              :return (make <ast-decls> :decls (cons decl rest-decls))
+              :return `(:decls ,decl ,@rest-decls)
               / Spaces* :return ())
     (TopDecls% <- Spaces* ";" Spaces* TopDecl TopDecls%
@@ -79 +75 @@
                 )
 
-    (FuncApplyExpression 
-     <- (:atom AtomExpression)
-     (:rest-atoms ((Spaces (:inatm AtomExpression) :return inatm) *))
-     Spaces* :return `(:funapply ,atom ,@rest-atoms))
+    (FuncApplyExpression <- AtomExpression +)
     (AtomExpression
      <- QVar
@@ -116 +109 @@
      / "~" Spaces* AtomPattern)
 
-    (QVar <- LexQVarId
-          / "(" Spaces* (:sym LexQVarSym) Spaces* ")" :return sym)
+    (QVar <- LexQVarId / "(" Spaces* LexQVarSym Spaces* ")")
     (GCon <- "(" Spaces* ")"
           / "[" Spaces* "]"
@@ -130 +122 @@
            / LexQtyCls "(" LexTyVar AType + ")")
     (SimpleType <- (:con LexTyCon) (:vars SimpleTypeVars)
-                :return (make <ast-simple-type> :name con :vars vars))
+                :return `(:type-name ,con :vars ,vars))
     (SimpleTypeVars <- Spaces (:var LexTyVar) (:vars SimpleTypeVars)
                     :return (cons var vars)
                     / :return ())
     (Type <- (:type BType) Spaces* (:rest-types Type%)
-          :return
-          (if (null? rest-types)
-              type
-              (make <ast-multi-type> :types (cons type rest-types))))
+          :return `(:type ,type ,@rest-types))
     (Type% <- "->" Spaces* (:type Type) (:rest-types Type%)
            :return (cons type rest-types)
            / :return ())
     (BType <- (:type AType) (:rest-types BType%) 
-           :return (cond 
-                    ((is-a? type <ast-single-type>)
-                     (begin (set! (type-vars type) rest-types)
-                            type))
-                    ((and (is-a? #?=type <ast-multi-type>)
-                          (null? #?=rest-types))
-                     type)
-                    (else (error "Type error"))))
+           :return (cons type rest-types))
     (BType% <- Spaces (:type AType) (:rest-types BType%)
             :return (cons type rest-types)
@@ -158 +140 @@
            / "(" Spaces* (:t1 Type) Spaces* ","
            Spaces* (:t2 Type) Spaces* (:rest AType%) ")"
-           :return (make <ast-single-type> :name '$Tuple
+           :return (make <ast-simple-type> :name '$Tuple
                          :arity (+ 2 (length rest))
                          :vars `(,t1 ,t2 ,@rest))
            / "[" Spaces* Type Spaces* "]"
-           / "(" Spaces* (:t Type) Spaces* ")" :return t)
+           / "(" Spaces* Type Spaces* ")")
     (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%)
             :return (cons t rest)
             / :return ())
-    (GtyCon <- (:tycon LexQtyCon)
-            :return (make <ast-single-type> :name (cadr tycon)
-                          :module (car tycon))
+    (GtyCon <- LexQtyCon
             / "(" Spaces* ")"
-            :return (make <ast-single-type> :name '$Unit :arity 0)
+            :return (make <ast-single-type> :name '$Unit :arity 0 :vars ())
             / "[" Spaces* "]"
             :return '(make <ast-single-type> :name '$Unit :arity 0)
@@ -224 +204 @@
     (LexQConSym <- (LexModId ".") ? LexConSym)
     (LexQtyCon <- (:mod ((LexModId ".") ?)) (:tycon LexTyCon)
-               :return (if mod `(,(car mod) ,tycon)
-                           `(#f ,tycon)))
+               :return (if mod `(:module ,(car mod) ,@tycon)
+                           `(:module #f ,@tycon)))
     (LexQtyCls <- (LexModId ".") ? LexTyCls)
     (LexGConSym <- ":" / LexQConSym )
@@ -249 +229 @@
 
 
-(define-method hascheme:ast-print ((ast <ast-decls>))
-  (let1 ast-decls (decls ast)
-    (unless (null? ast-decls)
-      (hascheme:ast-print (car ast-decls))
-      (unless (null? (cdr ast-decls))
-        (display "; ")
-        (for-each hascheme:ast-print (cdr ast-decls))))))
-
-(define-method hascheme:ast-print ((ast <ast-type-decl>))
-  (hascheme:ast-print (type-decl-left ast))
-  (display " = ")
-  (hascheme:ast-print (type-decl-right ast)))
-
-(define-method hascheme:ast-print ((ast <ast-simple-type>))
-  (let1 vars (type-vars ast)
-    (cond
-     ((null? vars) (display (type-name ast)))
-     (else
-      (display (type-name ast))
-      (for-each (lambda (sym) (format #t " ~a" sym))
-                vars)))))
-
-(define-method hascheme:ast-print ((ast <ast-single-type>))
-  (let1 vars (type-vars ast)
-    (cond
-     ((null? vars) (display (type-name ast)))
-     (else
-      (display (type-name ast))
-      (for-each (lambda (var)
-                  (cond
-                   ((symbol? var) (format #t " ~a" var))
-                   ((is-a? var <ast-type-var>)
-                    (display " ")
-                    (hascheme:ast-print var))
-                   ((is-a? var <ast>)
-                    (display " (")
-                    (hascheme:ast-print var)
-                    (display ")"))
-                   (error "Invalid type")))
-                vars)))))
-
-(define-method hascheme:ast-print ((ast <ast-type-var>))
-  (display (type-var ast)))
-
 (define (hascheme:parser-test)
   (test* "Simplest body" '(())