#cs(module parse mzscheme
     (require parser-tools/lex
              (prefix : parser-tools/lex-sre)
              "cfg-parser.ss"
	      parser-tools/yacc
              syntax/readerr
              "prims.ss")
     
     (define-lex-abbrevs [lex:letter (:or (:/ #\a #\z) (:/ #\A #\Z))]
                         [lex:digit (:/ #\0 #\9)]
                         [lex:whitespace (:or #\newline #\return #\tab #\space #\vtab)]
                         [lex:comment (:: (:* lex:whitespace) "comment" (:* (:~ #\;)) #\;)])
     
     (define-tokens non-terminals (<logical-value> 
                                   <type> <identifier> 
                                   <unsigned-integer> <unsigned-float> <string>
                                   
                                   GOTO IF THEN ELSE FOR DO STEP UNTIL WHILE
                                   OWN ARRAY STRING PROCEDURE SWITCH LABEL VALUE
                                   BEGIN END
                                   POWER PLUS MINUS TIMES SLASH DIVIDE
                                   LESS LESS-OR-EQUAL EQUAL GREATER-OR-EQUAL GREATER NOT-EQUAL ASSIGN
                                   NEGATE AND OR IMPLIES EQUIV
                                   COMMA COLON SEMICOLON
                                   OPEN CLOSE OPENSQ CLOSESQ
                                   EOF
                                   UNPARSEABLE))
     
     (define stx-for-original-property (read-syntax #f (open-input-string "original")))
     
     (define-syntax (token stx)
       (syntax-case stx ()
         [(_ name val)
          (identifier? (syntax name))
          (let ([name (syntax name)])
            (with-syntax ([token-name (datum->syntax-object
                                       name
                                       (string->symbol
                                        (format "token-~a" (syntax-e name))))]
                          [source-name (datum->syntax-object name 'source-name)]
                          [start-pos (datum->syntax-object name 'start-pos)]
                          [end-pos (datum->syntax-object name 'end-pos)])
              (syntax 
	       (token-name 
		(datum->syntax-object #f val
				      (list
				       source-name
				       (position-line start-pos)
				       (position-col start-pos)
				       (position-offset start-pos)
				       (- (position-offset end-pos)
					  (position-offset start-pos)))
				      stx-for-original-property)))))]))
     (define-syntax (ttoken stx)
       (syntax-case stx ()
         [(_ name)
          (identifier? (syntax name))
          (syntax (token name 'name))]))
     
     (define (lex source-name)
       (lexer
        [(:+ lex:whitespace) (void)]
        ["true" (token <logical-value> #t)]
        ["false" (token <logical-value> #f)]
        ["real" (token <type> 'real)]
        ["integer" (token <type> 'integer)]
        ["Boolean" (token <type> 'boolean)]
        ["goto" (ttoken GOTO)]
        ["if" (ttoken IF)]
        ["then" (ttoken THEN)]
        ["else" (ttoken ELSE)]
        ["for" (ttoken FOR)]
        ["do" (ttoken DO)]
        ["step" (ttoken STEP)]
        ["until" (ttoken UNTIL)]
        ["while" (ttoken WHILE)]
        ["own" (ttoken OWN)]
        ["array" (ttoken ARRAY)]
        ["string" (ttoken STRING)]
        ["procedure" (ttoken PROCEDURE)]
        ["switch" (ttoken SWITCH)]
        ["label" (ttoken LABEL)]
        ["value" (ttoken VALUE)]
        [(:: "begin" lex:comment) (ttoken BEGIN)]
        ["begin" (ttoken BEGIN)]
        [(:: "end" lex:comment) (ttoken BEGIN)]
        ["end" (ttoken END)]
        ["^" (token POWER 'expt)]
        ["+" (token PLUS '+)]
        ["-" (token MINUS '-)]
        ["*" (token TIMES '*)]
        ["/" (token SLASH '/)]
        ["div" (token DIVIDE 'quotient)]
        ["<" (token LESS '<)]
        ["<=" (token LESS-OR-EQUAL '<=)]
        ["=" (token EQUAL '=)]
        [">" (token GREATER '>)]
        [">=" (token GREATER-OR-EQUAL '>=)]
        ["!=" (token NOT-EQUAL '!=)]
        ["!" (token NEGATE '!)]
        ["&" (token AND '&)]
        ["|" (token OR '\|)]
        ["=>" (token IMPLIES '==>)]
        ["==" (token EQUIV '==)]
        [":=" (ttoken ASSIGN)]
        ["," (ttoken COMMA)]
        [":" (ttoken COLON)]
        [(:: ";" lex:comment) (ttoken SEMICOLON)]
        [";" (ttoken SEMICOLON)]
        ["(" (ttoken OPEN)]
        [")" (ttoken CLOSE)]
        ["[" (ttoken OPENSQ)]
        ["]" (ttoken CLOSESQ)]
        [(:: lex:letter (:* (:or lex:letter lex:digit))) (token <identifier> (string->symbol lexeme))]
        [(:+ lex:digit) (token <unsigned-integer> (string->number lexeme))]
        [(:or (:: (:+ lex:digit) #\. (:* lex:digit))
              (:: (:* lex:digit) #\. (:+ lex:digit))) (token <unsigned-float> (string->number lexeme))]
        [(:: #\` (:* (:~ #\' #\`)) #\') (let ([s lexeme])
                                          (token <string> (substring s 1 (sub1 (string-length s)))))]
        [(eof) (ttoken EOF)]
        [any-char (token UNPARSEABLE (string->symbol lexeme))]))
     
     (define parse
       (cfg-parser
        (tokens non-terminals)
        (start <program>)
        (end EOF)
        (error (lambda (a b stx) 
		 (raise-read-error (format "parse error near ~a" (syntax-e stx))
				   (syntax-source stx)
				   (syntax-line stx)
				   (syntax-column stx)
				   (syntax-position stx)
				   (syntax-span stx))))
        (suppress)
        (grammar 
         ;; ==================== Expressions ====================
         (<expression> [(<arithmetic-expression>) $1]
                       [(<Boolean-expression>) $1]
                       [(<designational-expression>) $1])
         ;; -------------------- Numbers --------------------
         (<arithmetic-expression> [(<simple-arithmetic-expression>) $1]
                                  [(IF <Boolean-expression> 
                                       THEN <simple-arithmetic-expression> 
                                       ELSE <arithmetic-expression>)
                                   (make-a60:if $2 $4 $6)])
         (<simple-arithmetic-expression> [(<term>) $1]
                                         [(<adding-operator> <term>) (make-a60:unary 'num 'num $1 $2)]
                                         [(<simple-arithmetic-expression> <adding-operator> <term>) 
                                          (make-a60:binary 'num 'num $2 $1 $3)])
         (<term> [(<factor>) $1]
                 [(<term> <multiplying-operator> <factor>) (make-a60:binary 'num 'num $2 $1 $3)])
         (<factor> [(<primary>) $1]
                   [(<factor> POWER <primary>) (make-a60:binary 'num 'num $2 $1 $3)])
         (<adding-operator> [(PLUS) $1]
                            [(MINUS) $1])
         (<multiplying-operator> [(TIMES) $1]
                                 [(SLASH) $1]
                                 [(DIVIDE) $1])
         (<primary> [(<unsigned-integer>) $1]
                    [(<unsigned-float>) $1]
                    [(<variable>) $1]
                    [(<function-designator>) $1]
                    [(OPEN <arithmetic-expression> CLOSE) $2])
         ;; -------------------- Booleans --------------------
         (<relational-operator> [(LESS) $1]
                                [(LESS-OR-EQUAL) $1]
                                [(EQUAL) $1]
                                [(GREATER-OR-EQUAL) $1]
                                [(GREATER) $1]
                                [(NOT-EQUAL) $1])
         (<relation> [(<simple-arithmetic-expression> <relational-operator> <simple-arithmetic-expression>)
                      (make-a60:binary 'bool 'num $2 $1 $3)])
         (<Boolean-primary> [(<logical-value>) $1]
                            [(<variable>) $1]
                            [(<function-designator>) $1]
                            [(<relation>) $1]
                            [(OPEN <Boolean-expression> CLOSE) $2])
         (<Boolean-secondary> [(<Boolean-primary>) $1]
                              [(NEGATE <Boolean-primary>) (make-a60:unary 'bool 'bool $1 $2)])
         (<Boolean-factor> [(<Boolean-secondary>) $1]
                           [(<Boolean-factor> AND <Boolean-secondary>) (make-a60:binary 'bool 'bool $2 $1 $3)])
         (<Boolean-term> [(<Boolean-factor>) $1]
                         [(<Boolean-term> OR <Boolean-factor>)  (make-a60:binary 'bool 'bool $2 $1 $3)])
         
         (<implication> [(<Boolean-term>) $1]
                        [(<implication> IMPLIES <Boolean-term>) (make-a60:binary 'bool 'bool $2 $1 $3)])
         (<simple-Boolean> [(<implication>) $1]
                           [(<simple-Boolean> EQUIV <implication>) (make-a60:binary 'bool 'bool $2 $1 $3)])
         (<Boolean-expression> [(<simple-Boolean>) $1]
                               [(IF <Boolean-expression> 
                                    THEN <simple-Boolean> 
                                    ELSE <Boolean-expression>)
				(make-a60:if $2 $4 $6)])
         ;; -------------------- Designationals --------------------
         (<label> [(<identifier>) $1]
                  [(<unsigned-integer>) $1])
         (<switch-identifier> [(<identifier>) $1])
         (<switch-designator> [(<switch-identifier> OPENSQ <arithmetic-expression> CLOSESQ)
                               (make-a60:subscript $1 $3)])
         (<simple-designational-expression> [(<label>) $1]
                                            [(<switch-designator>) $1]
                                            [(OPEN <designational-expression> CLOSE) $2])
         (<designational-expression> [(<simple-designational-expression>) $1]
                                     [(IF <Boolean-expression> 
                                          THEN <simple-designational-expression> 
                                          ELSE <designational-expression>)
				      (make-a60:if $2 $4 $6)])
         ;; -------------------- Variables --------------------
         (<subscript-list> [(<arithmetic-expression>) (list $1)]
                           [(<subscript-list> COMMA <arithmetic-expression>) (append $1 (list $3))])
         (<subscripted-variable> [(<identifier> OPENSQ <subscript-list> CLOSESQ) (make-a60:variable $1 $3)])
         (<variable> [(<identifier>) (make-a60:variable $1 null)]
                     [(<subscripted-variable>) $1])
         ;; -------------------- Function calls --------------------
         (<function-designator> [(<identifier> <actual-parameter-part>) (make-a60:app $1 $2)])
         ;; ==================== Statements ====================
         ;;  - - - - - - - - - - non-empty - - - - - - - - - - 
         (<unlabelled-basic-nonempty-statement> [(<assignment-statement>) $1]
                                                [(<go-to-statement>) $1]
                                                [(<procedure-statement>) $1])
         (<basic-nonempty-statement> [(<unlabelled-basic-nonempty-statement>) $1]
                                     [(<label> COLON <basic-statement>) (make-a60:label $1 $3)])
         (<unconditional-nonempty-statement> [(<basic-nonempty-statement>) $1]
                                             [(<compound-statement>) $1]
                                             [(<block>) $1])
         (<nonempty-statement> [(<unconditional-nonempty-statement>) $1]
                               [(<conditional-statement>) $1]
                               [(<for-statement>) $1])
         ;;  - - - - - - - - - - possibly empty - - - - - - - - - -          
         (<unlabelled-basic-statement> [(<unlabelled-basic-nonempty-statement>) $1]
                                       [(<dummy-statement>) $1])
         (<basic-statement> [(<unlabelled-basic-statement>) $1]
                            [(<label> COLON <basic-statement>) (make-a60:label $1 $3)])
         (<unconditional-statement> [(<basic-statement>) $1]
                                    [(<unconditional-nonempty-statement>) $1])
         (<statement> [(<unconditional-statement>) $1]
                      [(<nonempty-statement>) $1])
         ;; -------------------- block and compound --------------------
         (<compound-tail> [(<statement> END) (list $1)]
                          [(<statement> SEMICOLON <compound-tail>) (cons $1 $3)])
         (<block-head> [(BEGIN <declaration>) (list $2)]
                       [(<block-head> SEMICOLON <declaration>) (append $1 (list $3))])
         (<unlabelled-block> [(<block-head> SEMICOLON <compound-tail>) (make-a60:block $1 $3)])
         (<unlabelled-compound> [(BEGIN <compound-tail>) (make-a60:compound $2)])
         
         (<compound-statement> [(<unlabelled-compound>) $1]
                               [(<label> COLON <compound-statement>) (make-a60:label $1 $3)])
         (<block> [(<unlabelled-block>) $1]
                  [(<label> COLON <block>) (make-a60:label $1 $3)])
         ;; -------------------- assignment --------------------
         (<left-part> [(<variable> ASSIGN) $1])
         (<left-part-list> [(<left-part>) (list $1)]
                           [(<left-part-list> <left-part>) (append $1 (list $2))])
         (<assignment-statement> [(<left-part-list> <arithmetic-expression>) (make-a60:assign $1 $2)]
                                 [(<left-part-list> <Boolean-expression>) (make-a60:assign $1 $2)])
         ;; -------------------- goto --------------------
         (<go-to-statement> [(GOTO <designational-expression>) (make-a60:goto $2)])
         ;; -------------------- dummy --------------------
         (<dummy-statement> [() (make-a60:compound null)])
         ;; -------------------- conditional --------------------
         (<conditional-statement> [(IF <Boolean-expression> THEN <unconditional-statement>)
                                   (make-a60:branch $2 $4 (make-a60:compound null))]
                                  [(IF <Boolean-expression> THEN <unconditional-statement> ELSE <statement>)
                                   (make-a60:branch $2 $4 $6)]
                                  [(IF <Boolean-expression> THEN <for-statement>)
                                   (make-a60:branch $2 $4 (make-a60:compound null))]
                                  [(<label> COLON <conditional-statement>) (make-a60:label $1 $3)])
         ;; -------------------- for --------------------
         (<for-list-element> [(<arithmetic-expression>) (make-a60:for-number $1)]
                             [(<arithmetic-expression> STEP <arithmetic-expression> UNTIL <arithmetic-expression>)
                              (make-a60:for-step $1 $3 $5)]
                             [(<arithmetic-expression> WHILE <Boolean-expression>) (make-a60:for-while $1 $3)])
         (<for-list> [(<for-list-element>) (list $1)]
                     [(<for-list> COMMA <for-list-element>) (append $1 (list $3))])
         (<for-statement> [(FOR <variable> ASSIGN <for-list> DO <statement>)
                           (make-a60:for $2 $4 $6)]
                          [(<label> COLON <for-statement>) (make-a60:label $1 $3)])
         ;; -------------------- procedure statement --------------------
         (<actual-parameter> [(<string>) $1]
                             [(<expression>) $1]
                             ; [(<identifier>) $1] ; switch, array, or procedure
                             )
         (<parameter-delimiter> [(COMMA) (void)]
                                [(CLOSE <identifier> COLON OPEN) (void)]) ;; <identifier> was <letter-string>!
         (<actual-parameter-list> [(<actual-parameter>) (list $1)]
                                  [(<actual-parameter-list> <parameter-delimiter> <actual-parameter>)
                                   (append $1 (list $3))])
         (<actual-parameter-part> [() null]
                                  [(OPEN <actual-parameter-list> CLOSE) $2])
         (<procedure-statement> [(<identifier> <actual-parameter-part>) (make-a60:call $1 $2)])
         ;; ==================== Declarations ====================
         (<declaration> [(<type-declaration>) $1]
                        [(<array-declaration>) $1]
                        [(<switch-declaration>) $1]
                        [(<procedure-declaration>) $1])
         ;; -------------------- Simple --------------------
         (<type-list> [(<identifier>) (list $1)]
                      [(<identifier> COMMA <type-list>) (cons $1 $3)])
         (<local-or-own-type> [(<type>) $1]
                              [(OWN <type>) (box $2)]) ; box => own
         (<type-declaration> [(<local-or-own-type> <type-list>) (make-a60:type-decl $1 $2)])
         ;; -------------------- Arrays --------------------
         (<bound-pair> [(<arithmetic-expression> COLON <arithmetic-expression>) (cons $1 $3)])
         (<bound-pair-list> [(<bound-pair>) (list $1)]
                            [(<bound-pair-list> COMMA <bound-pair>) (append $1 (list $3))])
         (<array-segment> [(<identifier> OPENSQ <bound-pair-list> CLOSESQ) (list (cons $1 $3))]
                          [(<identifier> COMMA <array-segment>) (cons (cons $1 (cdar $3)) $3)])
         (<array-list> [(<array-segment>) $1]
                       [(<array-list> COMMA <array-segment>) (append $1 $3)])
         (<array-declaration> [(ARRAY <array-list>) (make-a60:array-decl #'unknown $2)]
                              [(<local-or-own-type> ARRAY <array-list>) (make-a60:array-decl $1 $3)])
         ;; -------------------- Switches --------------------
         (<switch-list> [(<designational-expression>) (list $1)]
                        [(<switch-list> COMMA <designational-expression>) (append $1 (list $3))])
         (<switch-declaration> [(SWITCH <switch-identifier> ASSIGN <switch-list>) (make-a60:switch-decl $2 $4)])
         ;; -------------------- Procedures --------------------
         (<formal-parameter> [(<identifier>) $1])
         (<formal-parameter-list> [(<formal-parameter>) (list $1)]
                                  [(<formal-parameter-list> <parameter-delimiter> <formal-parameter>) 
                                   (append $1 (list $3))])
         (<formal-parameter-part> [() null]
                                  [(OPEN <formal-parameter-list> CLOSE) $2])
         (<identifier-list> [(<identifier>) (list $1)]
                            [(<identifier-list> COMMA <identifier>) (append $1 (list $3))])
         (<value-part> [(VALUE <identifier-list> SEMICOLON) $2]
                       [() null])
         (<specifier> [(STRING) 'string]
                      [(<type>) $1]
                      [(ARRAY) '(array #'unknown)]
                      [(<type> ARRAY) `(array ,$1)]
                      [(LABEL) 'label]
                      [(SWITCH) 'switch]
                      [(PROCEDURE) '(procedure #'unknown)]
                      [(<type> PROCEDURE) `(procedure ,$1)])
         (<nonempty-specification-part> [(<specifier> <identifier-list> SEMICOLON) (list (cons $1 $2))]
                                        [(<nonempty-specification-part> <specifier> <identifier-list> SEMICOLON)
                                         (append $1 (list (cons $2 $3)))])
         (<specification-part> [() null]
                               [(<nonempty-specification-part>) $1])
         (<procedure-heading> [(<identifier> <formal-parameter-part> SEMICOLON <value-part> <specification-part>)
                               (list $1 $2 $4 $5)])
         (<procedure-body> [(<nonempty-statement>) $1])
         (<procedure-declaration> [(PROCEDURE <procedure-heading> <procedure-body>)
                                   (make-a60:proc-decl #'unknown (car $2) (cadr $2) (caddr $2) (cadddr $2) $3)]
                                  [(<type> PROCEDURE <procedure-heading> <procedure-body>)
                                   (make-a60:proc-decl $1 (car $3) (cadr $3) (caddr $3) (cadddr $3) $4)])
         ;; ==================== Program ====================
         (<program> [(<block>) $1]
                    [(<compound-statement>) $1]))))
     
     (define-syntax (define-a60-structs stx)
       (syntax-case stx ()
         [(_ (struct-name (field ...)) ...)
          (with-syntax ([(a60:struct ...) (map (lambda (id)
						 (datum->syntax-object
						  id
						  (string->symbol
						   (format "a60:~a" (syntax-e id)))))
                                               (syntax->list (syntax (struct-name ...))))])
            (syntax (begin (define-struct a60:struct (field ...)) ...
                           (provide (struct a60:struct (field ...)) ...))))]))
     
     (define-a60-structs
      ;; Expressions
      (if (test then else))
      (unary (type argtype op arg))
      (binary (type argtype op arg1 arg2))
      (subscript (array index))
      (variable (name indices))
      (app (func args))
      ;; plus numbers, strings, and booleans

      ;; Statements
      (block (decls statements))
      (compound (statements))
      (assign (variables rhs))
      (goto (target))
      (branch (test then else))
      (call (proc args))
      (for (variable values body))
      (dummy ())
      (label (name statement))
      
      ;; for values
      (for-number (value))
      (for-step (start step end))
      (for-while (value test))

      ;; declarations
      (type-decl (type vars))
      (array-decl (type vars))
      (switch-decl (var cases))
      (proc-decl (result-type var arg-vars by-value-vars arg-specs body)))
     
     (define (parse-a60-port port file)
       (let ([lexer (lex file)])
	 (port-count-lines! port)
         (parse
          (lambda () 
            (let loop ()
              (let ([v (lexer port)])
                (if (void? v)
                    (loop)
                    v)))))))
     
     (define (parse-a60-file file)
       (with-input-from-file file
         (lambda ()
           (parse-a60-port (current-input-port)
                           (path->complete-path file)))))

      (provide parse-a60-file parse-a60-port))