Show
Ignore:
Timestamp:
03/09/08 12:59:51 (17 years ago)
Author:
hayamizu
Message:

worte parser

Files:
1 modified

Legend:

Unmodified
Added
Removed
  • hh2008/hayamiz/trunk/hascheme/parser.scm

    r15 r23  
    66(define-class <ast> () ()) 
    77(define-class <ast-decl> (<ast>) ()) 
     8(define-class <ast-decls> (<ast>) 
     9  ((delcs :init-keyword :decls :getter decls))) 
    810(define-class <ast-type-decl> (<ast-decl>) 
    911  ((left :init-keyword :left :getter type-decl-left) 
     
    1416(define-class <ast-single-type> (<ast-type>) 
    1517  ((type-name :init-keyword :name :getter type-name) 
    16    (type-arity :init-keyword :arity :accessor type-arity) 
     18   (type-arity :init-keyword :arity :accessor type-arity :init-value #f) 
    1719   (type-vars :init-keyword :vars :accessor type-vars :init-value #f) 
    1820   (type-module :init-keyword :module :getter type-module :init-value #f))) 
    1921(define-class <ast-multi-type> (<ast-type>) 
    2022  ((types :init-keyword :name :accessor types))) 
    21 (define-class <ast-simple-type> (<ast>) ()) 
     23(define-class <ast-simple-type> (<ast>) 
     24  ((type-name :init-keyword :name :getter type-name) 
     25   (type-vars :init-keyword :vars :getter type-vars))) 
     26 
    2227(define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>)) 
    23   ; (make <type-decl> :left left :right right) 
    24   `(:type-decl ,left ,right)) 
     28  (make <ast-type-decl> :left left :right right)) 
    2529 
    2630(define (hascheme:parse str) 
     
    3236    (Body <- "{" (:decls TopDecls) "}" :return decls) 
    3337    (TopDecls <- Spaces* (:decl TopDecl) (:rest-decls TopDecls%) Spaces* 
    34               :return `(:decls ,decl ,@rest-decls) 
     38              :return (make <ast-decls> :decls (cons decl rest-decls)) 
    3539              / Spaces* :return ()) 
    3640    (TopDecls% <- Spaces* ";" Spaces* TopDecl TopDecls% 
     
    7579                ) 
    7680 
    77     (FuncApplyExpression <- AtomExpression +) 
     81    (FuncApplyExpression  
     82     <- (:atom AtomExpression) 
     83     (:rest-atoms ((Spaces (:inatm AtomExpression) :return inatm) *)) 
     84     Spaces* :return `(:funapply ,atom ,@rest-atoms)) 
    7885    (AtomExpression 
    7986     <- QVar 
     
    109116     / "~" Spaces* AtomPattern) 
    110117 
    111     (QVar <- LexQVarId / "(" Spaces* LexQVarSym Spaces* ")") 
     118    (QVar <- LexQVarId 
     119          / "(" Spaces* (:sym LexQVarSym) Spaces* ")" :return sym) 
    112120    (GCon <- "(" Spaces* ")" 
    113121          / "[" Spaces* "]" 
     
    122130           / LexQtyCls "(" LexTyVar AType + ")") 
    123131    (SimpleType <- (:con LexTyCon) (:vars SimpleTypeVars) 
    124                 :return `(:type-name ,con :vars ,vars)) 
     132                :return (make <ast-simple-type> :name con :vars vars)) 
    125133    (SimpleTypeVars <- Spaces (:var LexTyVar) (:vars SimpleTypeVars) 
    126134                    :return (cons var vars) 
    127135                    / :return ()) 
    128136    (Type <- (:type BType) Spaces* (:rest-types Type%) 
    129           :return `(:type ,type ,@rest-types)) 
     137          :return 
     138          (if (null? rest-types) 
     139              type 
     140              (make <ast-multi-type> :types (cons type rest-types)))) 
    130141    (Type% <- "->" Spaces* (:type Type) (:rest-types Type%) 
    131142           :return (cons type rest-types) 
    132143           / :return ()) 
    133144    (BType <- (:type AType) (:rest-types BType%)  
    134            :return (cons type rest-types)) 
     145           :return (cond  
     146                    ((is-a? type <ast-single-type>) 
     147                     (begin (set! (type-vars type) rest-types) 
     148                            type)) 
     149                    ((and (is-a? #?=type <ast-multi-type>) 
     150                          (null? #?=rest-types)) 
     151                     type) 
     152                    (else (error "Type error")))) 
    135153    (BType% <- Spaces (:type AType) (:rest-types BType%) 
    136154            :return (cons type rest-types) 
     
    140158           / "(" Spaces* (:t1 Type) Spaces* "," 
    141159           Spaces* (:t2 Type) Spaces* (:rest AType%) ")" 
    142            :return (make <ast-simple-type> :name '$Tuple 
     160           :return (make <ast-single-type> :name '$Tuple 
    143161                         :arity (+ 2 (length rest)) 
    144162                         :vars `(,t1 ,t2 ,@rest)) 
    145163           / "[" Spaces* Type Spaces* "]" 
    146            / "(" Spaces* Type Spaces* ")") 
     164           / "(" Spaces* (:t Type) Spaces* ")" :return t) 
    147165    (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%) 
    148166            :return (cons t rest) 
    149167            / :return ()) 
    150     (GtyCon <- LexQtyCon 
     168    (GtyCon <- (:tycon LexQtyCon) 
     169            :return (make <ast-single-type> :name (cadr tycon) 
     170                          :module (car tycon)) 
    151171            / "(" Spaces* ")" 
    152             :return (make <ast-single-type> :name '$Unit :arity 0 :vars ()) 
     172            :return (make <ast-single-type> :name '$Unit :arity 0) 
    153173            / "[" Spaces* "]" 
    154174            :return '(make <ast-single-type> :name '$Unit :arity 0) 
     
    204224    (LexQConSym <- (LexModId ".") ? LexConSym) 
    205225    (LexQtyCon <- (:mod ((LexModId ".") ?)) (:tycon LexTyCon) 
    206                :return (if mod `(:module ,(car mod) ,@tycon) 
    207                            `(:module #f ,@tycon))) 
     226               :return (if mod `(,(car mod) ,tycon) 
     227                           `(#f ,tycon))) 
    208228    (LexQtyCls <- (LexModId ".") ? LexTyCls) 
    209229    (LexGConSym <- ":" / LexQConSym ) 
     
    229249 
    230250 
     251(define-method hascheme:ast-print ((ast <ast-decls>)) 
     252  (let1 ast-decls (decls ast) 
     253    (unless (null? ast-decls) 
     254      (hascheme:ast-print (car ast-decls)) 
     255      (unless (null? (cdr ast-decls)) 
     256        (display "; ") 
     257        (for-each hascheme:ast-print (cdr ast-decls)))))) 
     258 
     259(define-method hascheme:ast-print ((ast <ast-type-decl>)) 
     260  (hascheme:ast-print (type-decl-left ast)) 
     261  (display " = ") 
     262  (hascheme:ast-print (type-decl-right ast))) 
     263 
     264(define-method hascheme:ast-print ((ast <ast-simple-type>)) 
     265  (let1 vars (type-vars ast) 
     266    (cond 
     267     ((null? vars) (display (type-name ast))) 
     268     (else 
     269      (display (type-name ast)) 
     270      (for-each (lambda (sym) (format #t " ~a" sym)) 
     271                vars))))) 
     272 
     273(define-method hascheme:ast-print ((ast <ast-single-type>)) 
     274  (let1 vars (type-vars ast) 
     275    (cond 
     276     ((null? vars) (display (type-name ast))) 
     277     (else 
     278      (display (type-name ast)) 
     279      (for-each (lambda (var) 
     280                  (cond 
     281                   ((symbol? var) (format #t " ~a" var)) 
     282                   ((is-a? var <ast-type-var>) 
     283                    (display " ") 
     284                    (hascheme:ast-print var)) 
     285                   ((is-a? var <ast>) 
     286                    (display " (") 
     287                    (hascheme:ast-print var) 
     288                    (display ")")) 
     289                   (error "Invalid type"))) 
     290                vars))))) 
     291 
     292(define-method hascheme:ast-print ((ast <ast-type-var>)) 
     293  (display (type-var ast))) 
     294 
    231295(define (hascheme:parser-test) 
    232296  (test* "Simplest body" '(())