tvl-depot/third_party/lisp/npg/examples/vs-cobol-ii.lisp

;;;  vs-cobol-ii.lisp --- sample grammar for VS-Cobol II

;;;  Copyright (C) 2003 by Walter C. Pelissero

;;;  Author: Walter C. Pelissero <walter@pelissero.de>
;;;  Project: NPG a Naive Parser Generator
;;;  $Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA

;;;  Commentary:
;;;
;;; A fairly incomplete VS-Cobol II grammar fro NPG.  It's probably
;;; not very accurate either.

#+cmu (ext:file-comment "$Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $")

(in-package :grammar)

(defun make-keyword (string)
  "Create a keyword from STRING."
  (intern (string-upcase string) :keyword))

(defun flatten-list (list)
  "Remove one depth level in LIST."
  (mapcan #'identity list))

(deflazy define-grammar
  (let ((*package* #.*package*)
        (*compile-print* (and parser::*debug* t)))
    (reset-grammar)
    (format t "creating Cobol grammar...~%")
    (populate-grammar)
    (let ((grammar (parser:generate-grammar)))
      (reset-grammar)
      (parser:print-grammar-figures grammar)
      grammar)))

(defun populate-grammar ()
;;;
;;; Hereafter PP means Partial Program
;;;

#+nil
(defrule pp--declarations
    := identification-division environment-division? data-division? "PROCEDURE" "DIVISION" using-phrase? "." :rest)

;;; We need to split the parsing of the declarations from the rest
;;; because the declarations may change the lexical rules (ie decimal
;;; point)

(defrule pp--declarations
    := identification-division environment-division? data-division-head-or-procedure-division-head :rest)

(defrule data-division-head-or-procedure-division-head
    := data-division-head
    :reduce :data-division
    := procedure-division-head
    :reduce (list :procedure-division $1))

(defrule pp--data-division
    := data-division-content procedure-division-head :rest)

(defrule pp--sentence
    := sentence :rest
    := :eof)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The real grammar
;;;

(defrule cobol-source-program
    := identification-division environment-division? data-division procedure-division end-program?)

(defrule identification-division
    := identification "DIVISION" "." program-id-cobol-source-program identification-division-content
    :reduce program-id-cobol-source-program)

(defrule priority-number
    := integer)

(defrule level-number
    := integer)

(defrule to-id-or-lit
    := "TO" id-or-lit)

(defrule inspect-by-argument
    := variable-identifier
    := string
    := figurative-constant-simple)

(defrule figurative-constant-simple
    := "ZERO"
    :reduce :zero
    := "ZEROS"
    :reduce :zero
    := "ZEROES"
    :reduce :zero
    := "SPACE"
    :reduce :space
    := "SPACES"
    :reduce :space
    := "HIGH-VALUE"
    :reduce :high
    := "HIGH-VALUES"
    :reduce :high
    := "LOW-VALUE"
    :reduce :low
    := "LOW-VALUES"
    :reduce :low
    := "QUOTE"
    :reduce :quote
    := "QUOTES"
    :reduce :quote
    := "NULL"
    :reduce :null
    := "NULLS"
    :reduce :null)

(defrule write-exceptions
    := at-end-of-page-statement-list? not-at-end-of-page-statement-list? invalid-key-statement-list? not-invalid-key-statement-list?)

(defrule set-statement-phrase
    := variable-identifier+ set-oper set-src)

(defrule set-src
    := variable-identifier
    := literal
    := "TRUE"
    := "ON"
    := "OFF")

(defrule set-oper
    := "TO"
    :reduce :to
    := "UP" "BY"
    :reduce :up
    := "DOWN" "BY"
    :reduce :down)

(defrule fce-phrase
    := reserve-clause
    := fce-organization
    := fce-access-mode
    := record-key-clause
    := password-clause
    := alternate-record-key-clause
    := file-status-clause
    := padding-character-clause
    := record-delimiter-clause)

(defrule fce-organization
    := organization-is? alt-indexed-relative-sequential
    :reduce (list :organization (make-keyword alt-indexed-relative-sequential)))

(defrule fce-access-mode
    := "ACCESS" "MODE"? "IS"? alt-sequential-random-dynamic relative-key-clause?
    :reduce (list :access-mode (make-keyword alt-sequential-random-dynamic)))

(defrule alt-indexed-relative-sequential
    := "INDEXED"
    := "RELATIVE"
    := "SEQUENTIAL")

(defrule is-not
    := "IS"? "NOT"?)

(defrule all-procedures
    := "ALL" "PROCEDURES")

(defrule next-sentence
    := "NEXT" "SENTENCE")

(defrule no-rewind
    := "NO" "REWIND")

(defrule for-removal
    := "FOR"? "REMOVAL")

(defrule values
    := "VALUE"
    := "VALUES")

(defrule records
    := "RECORD"
    := "RECORDS")

(defrule end-program
    := "END" "PROGRAM" program-name ".")

(defrule environment-division
    := "ENVIRONMENT" "DIVISION" "." environment-division-content)

(defrule data-division-head
    := "DATA" "DIVISION" ".")

(defrule data-division
    := data-division-head data-division-content
    :reduce data-division-content)

(defrule identification
    := "IDENTIFICATION"
    := "ID")

(defrule identification-division-content
    := identification-division-phrase*)

(defrule author
    := "AUTHOR" ".")

(defrule installation
    := "INSTALLATION" ".")

(defrule date-written
    := "DATE-WRITTEN" ".")

(defrule date-compiled
    := "DATE-COMPILED" ".")

(defrule security
    := "SECURITY" ".")

(defrule remarks
    := "REMARKS" ".")

(defrule identification-division-phrase
    := author
    := installation
    := date-written
    := date-compiled
    := security
    := remarks)

(defrule program-id-cobol-source-program
    := "PROGRAM-ID" "."? program-name initial-program? "."
    :reduce program-name)

(defrule initial-program
    := "IS"? "INITIAL" "PROGRAM"?)

(defrule environment-division-content
    := configuration-section? input-output-section?)

(defrule input-output-section
    := "INPUT-OUTPUT" "SECTION" "." file-control-paragraph? i-o-control-paragraph?
    :reduce file-control-paragraph)

(defrule file-control-paragraph
    := "FILE-CONTROL" "." file-control-entry*)

(defrule file-control-entry
    := select-clause assign-clause fce-phrase* "."
    :reduce (append select-clause
                    assign-clause
                    (flatten-list fce-phrase)))

(defrule organization-is
    := "ORGANIZATION" "IS"?)

(defrule alt-sequential-random-dynamic
    := "SEQUENTIAL"
    := "RANDOM"
    := "DYNAMIC")

(defrule select-clause
    := "SELECT" "OPTIONAL"? file-name
    :reduce (list file-name :optional (and $2 t)))

(defrule assign-clause
    := "ASSIGN" "TO"? alt-assignment-name-literal+
    :reduce (list :assign alt-assignment-name-literal))

(defrule alt-assignment-name-literal
    := assignment-name
    := literal)

(defrule reserve-clause
    := "RESERVE" integer areas?)

(defrule areas
    := "AREA"
    := "AREAS")

(defrule padding-character-clause
    := "PADDING" "CHARACTER"? "IS"? alt-qualified-data-name-literal)

(defrule record-delimiter-clause
    := "RECORD" "DELIMITER" "IS"? record-delimiter-name)

(defrule record-delimiter-name
    := "STANDARD-1"
    := assignment-name)

(defrule password-clause
    := "PASSWORD" "IS"? data-name)

(defrule file-status-clause
    := "FILE"? "STATUS" "IS"? qualified-data-name qualified-data-name?
    :reduce (list :file-status qualified-data-name))

(defrule relative-key-clause
    := "RELATIVE" "KEY"? "IS"? qualified-data-name
    :reduce (list :relative-key qualified-data-name))

(defrule record-key-clause
    := "RECORD" "KEY"? "IS"? qualified-data-name
    :reduce (list :key qualified-data-name))

(defrule alternate-record-key-clause
    := "ALTERNATE" "RECORD"? "KEY"? "IS"? qualified-data-name password-clause? with-duplicates?
    :reduce (list :alternate-key qualified-data-name with-duplicates))

(defrule with-duplicates
    := "WITH"? "DUPLICATES")

(defrule i-o-control-paragraph
    := "I-O-CONTROL" "." i-o-sam? i-o-sort-merge?)

(defrule i-o-sam
    := qsam-or-sam-or-vsam-i-o-control-entries+ ".")

(defrule i-o-sort-merge
    := sort-merge-i-o-control-entries ".")

(defrule qsam-or-sam-or-vsam-i-o-control-entries
    := qsam-or-sam-or-vsam-i-o-control-entries-1
    := qsam-or-sam-or-vsam-i-o-control-entries-2
    := qsam-or-sam-or-vsam-i-o-control-entries-3
    := qsam-or-sam-or-vsam-i-o-control-entries-4)

(defrule qsam-or-sam-or-vsam-i-o-control-entries-1
    := "RERUN" "ON" alt-assignment-name-file-name "EVERY"? every-phrase "OF"? file-name)

(defrule every-phrase-1
    := integer "RECORDS")

(defrule every-phrase-2
    := "END" "OF"? alt-reel-unit)

(defrule every-phrase
    := every-phrase-1
    := every-phrase-2)

(defrule alt-assignment-name-file-name
    := assignment-name
    := file-name)

(defrule qsam-or-sam-or-vsam-i-o-control-entries-2
    := "SAME" "RECORD"? "AREA"? "FOR"? file-name file-name+)

(defrule qsam-or-sam-or-vsam-i-o-control-entries-3
    := "MULTIPLE" "FILE" "TAPE"? "CONTAINS"? file-name-position+)

(defrule position
    := "POSITION" integer)

(defrule file-name-position
    := file-name position?)

(defrule qsam-or-sam-or-vsam-i-o-control-entries-4
    := "APPLY" "WRITE-ONLY" "ON"? file-name+)

(defrule sort-merge-i-o-control-entries
    := rerun-on? same-area+)

(defrule rerun-on
    := "RERUN" "ON" assignment-name)

(defrule record-sort
    := "RECORD"
    := "SORT"
    := "SORT-MERGE")

(defrule same-area
    := "SAME" record-sort "AREA"? "FOR"? file-name file-name+)

(defrule configuration-section
    := "CONFIGURATION" "SECTION" "." configuration-section-paragraph*
    :reduce (flatten-list configuration-section-paragraph))

(defrule configuration-section-paragraph
    := source-computer-paragraph
    := object-computer-paragraph
    := special-names-paragraph)

(defrule source-computer-paragraph
    := "SOURCE-COMPUTER" "." source-computer-name
    :reduce (list :source-computer source-computer-name))

(defrule with-debugging-mode
    := "WITH"? "DEBUGGING" "MODE")

(defrule source-computer-name
    := computer-name with-debugging-mode? "."
    :reduce computer-name)

(defrule object-computer-paragraph
    := "OBJECT-COMPUTER" "." object-computer-name
    :reduce (list :object-computer object-computer-name))

(defrule memory-size-type
    := "WORDS"
    := "CHARACTERS"
    := "MODULES")

(defrule memory-size
    := "MEMORY" "SIZE"? integer memory-size-type)

(defrule object-computer-name
    := computer-name memory-size? object-computer-paragraph-sequence-phrase "."
    :reduce computer-name)

(defrule object-computer-paragraph-sequence-phrase
    := program-collating-sequence? segment-limit?)

(defrule program-collating-sequence
    := "PROGRAM"? "COLLATING"? "SEQUENCE" "IS"? alphabet-name)

(defrule segment-limit
    := "SEGMENT-LIMIT" "IS"? priority-number)

(defrule special-names-paragraph
    := "SPECIAL-NAMES" "." special-names-paragraph-phrase* special-names-paragraph-clause* "."
    :reduce (flatten-list special-names-paragraph-clause))

(defrule is-mnemonic-name
    := "IS"? mnemonic-name special-names-paragraph-status-phrase?)

(defrule special-names-paragraph-phrase-tail
    := is-mnemonic-name
    := special-names-paragraph-status-phrase)

(defrule special-names-paragraph-phrase
    := environment-name special-names-paragraph-phrase-tail)

(defrule special-names-paragraph-status-phrase
    := special-names-paragraph-status-phrase-1
    := special-names-paragraph-status-phrase-2)

(defrule special-names-paragraph-status-phrase-1
    := "ON" "STATUS"? "IS"? condition off-status?)

(defrule off-status
    := "OFF" "STATUS"? "IS"? condition)

(defrule special-names-paragraph-status-phrase-2
    := "OFF" "STATUS"? "IS"? condition on-status?)

(defrule on-status
    := "ON" "STATUS"? "IS"? condition)

(defrule special-names-paragraph-clause
    ;; := alphabet-clause
    ;; := symbolic-characters-clause
    := currency-sign-clause
    := decimal-point-clause)

(defrule alphabet-clause
    := "ALPHABET" alphabet-name "IS"? alphabet-type)

(defrule alphabet-type-also
    := "ALSO" literal)

(defrule alphabet-type-alsos
    := alphabet-type-also+)

(defrule alphabet-type-also-through
    := through-literal
    := alphabet-type-alsos)

(defrule alphabet-type-other
    := literal alphabet-type-also-through?)

(defrule alphabet-type-others
    := alphabet-type-other+)

(defrule alphabet-type
    := "STANDARD-1"
    := "STANDARD-2"
    := "NATIVE"
    := "EBCDIC"
    := alphabet-type-others)

(defrule symbolic-characters-clause
    := "SYMBOLIC" "CHARACTERS"? symbolic-character-mapping+ in-alphabet-name?)

(defrule are
    := "ARE"
    := "IS")

(defrule symbolic-character-mapping
    := symbolic-character+ are? integer+)

(defrule in-alphabet-name
    := "IN" alphabet-name)

(defrule currency-sign-clause
    := "CURRENCY" "SIGN"? "IS"? literal
    :reduce (list :currency-sign literal))

(defrule decimal-point-clause
    := "DECIMAL-POINT" "IS"? "COMMA"
    :reduce (list :decimal-point #\,))

(defrule data-division-content
    := file-section? working-storage-section? linkage-section?)

(defrule file-section-entry
    := file-and-sort-description-entry data-description-entry+
    :reduce (cons file-and-sort-description-entry data-description-entry))

(defrule file-section-head
    := "FILE" "SECTION" ".")

(defrule file-section
    := file-section-head file-section-entry*
    :reduce $2)

(defrule working-storage-section-head
    := "WORKING-STORAGE" "SECTION" ".")

(defrule working-storage-section
    := working-storage-section-head data-description-entry*
    :reduce $2)

(defrule linkage-section-head
    := "LINKAGE" "SECTION" ".")

(defrule linkage-section
    := linkage-section-head data-description-entry*
    :reduce $2)

(defrule file-and-sort-description-entry
    := alt-fd-sd file-name file-and-sort-description-entry-clause* "."
    :reduce (list (make-keyword alt-fd-sd) file-name file-and-sort-description-entry-clause))

(defrule alt-fd-sd
    := "FD"
    := "SD")

(defrule file-and-sort-description-entry-clause
    := external-clause
    := global-clause
    := block-contains-clause
    := record-clause
    := label-records-clause
    := value-of-clause
    := data-records-clause
    := linage-clause
    := recording-mode-clause
    := code-set-clause)

(defrule integer-to
    := integer "TO")

(defrule block-contains-clause
    := "BLOCK" "CONTAINS"? integer-to? integer alt-characters-records?)

(defrule alt-characters-records
    := "CHARACTERS"
    := "RECORDS"
    := "RECORD")

(defrule record-clause
    := "RECORD" record-clause-tail)

(defrule depending-on
    := "DEPENDING" "ON"? data-name)

(defrule record-clause-tail-1
    := "CONTAINS"? integer "CHARACTERS"?)

(defrule record-clause-tail-2
    := "CONTAINS"? integer "TO" integer "CHARACTERS"?)

(defrule record-clause-tail-3
    := record-varying-phrase depending-on?)

(defrule record-clause-tail
    := record-clause-tail-2
    := record-clause-tail-1
    := record-clause-tail-3)

(defrule record-varying-phrase
    := "IS"? "VARYING" "IN"? "SIZE"? from-integer? to-integer? "CHARACTERS"?)

(defrule from-integer
    := "FROM"? integer)

(defrule to-integer
    := "TO" integer)

(defrule label-records-clause
    := "LABEL" records-are label-records-clause-tail
    :reduce (list :label-record label-records-clause-tail))

(defrule data-names
    := data-name+)

(defrule label-records-clause-tail
    := "STANDARD" :reduce :standard
    := "OMITTED" :reduce :omitted
    := data-names)

(defrule value-of-clause
    := "VALUE" "OF" value-of-clause-tail+)

(defrule alt-qualified-data-name-literal
    := qualified-data-name
    := literal)

(defrule value-of-clause-tail
    := variable-identifier "IS"? alt-qualified-data-name-literal)

(defrule data-records-clause
    := "DATA" records-are data-name+)

(defrule records-are
    := records are?)

(defrule linage-clause
    := "LINAGE" "IS"? alt-data-name-integer "LINES"? linage-footing-phrase)

(defrule linage-footing-phrase
    := footing? lines-top? lines-bottom?)

(defrule alt-data-name-integer
    := data-name
    := integer)

(defrule footing
    := "WITH"? "FOOTING" "AT"? alt-data-name-integer)

(defrule lines-top
    := "LINES"? "AT"? "TOP" alt-data-name-integer)

(defrule lines-bottom
    := "LINES"? "AT"? "BOTTOM" alt-data-name-integer)

(defrule recording-mode-clause
    := "RECORDING" "MODE"? "IS"? variable-identifier)

(defrule code-set-clause
    := "CODE-SET" "IS"? alphabet-name)

(defrule data-description-entry
    := level-number alt-data-name-filler? data-description-entry-clause* "."
    :reduce (append (list level-number alt-data-name-filler)
                    (flatten-list data-description-entry-clause)))

(defrule alt-data-name-filler
    := data-name
    := "FILLER"
    :reduce (list))

(defrule data-description-entry-clause
    := picture-clause
    := redefines-clause
    := blank-when-zero-clause
    := external-clause
    := global-clause
    := justified-clause
    := occurs-clause
    := sign-clause
    := synchronized-clause
    := usage-clause
    := renames-clause
    := value-clause)

(defrule value-clause
    := "VALUE" "IS"? literal
    :reduce (list :value literal))

(defrule redefines-clause
    := "REDEFINES" data-name
    :reduce `(:redefines ,data-name))

(defrule blank-when-zero-clause
    := "BLANK" "WHEN"? zeroes
    :reduce '(:blank-when-zero t))

(defrule zeroes
    := "ZERO"
    := "ZEROS"
    := "ZEROES")

(defrule external-clause
    := "IS"? "EXTERNAL"
    :reduce '(:external t))

(defrule global-clause
    := "IS"? "GLOBAL"
    :reduce '(:global t))

(defrule justified-clause
    := justified "RIGHT"?
    :reduce `(:justified ,(if $2 :right :left)))

(defrule justified
    := "JUSTIFIED"
    := "JUST")

(defrule occurs-clause
    := "OCCURS" integer "TIMES"? occurs-clause-key* indexed-by?
    ;; to be completed -wcp16/7/03.
    :reduce `(:times ,integer)
    := "OCCURS" integer "TO" integer "TIMES"? "DEPENDING" "ON"? qualified-data-name occurs-clause-key* indexed-by?
    ;; to be completed -wcp16/7/03.
    :reduce `(:times (,integer ,integer2 ,qualified-data-name)))

(defrule occurs-clause-key
    := alt-ascending-descending "KEY"? "IS"? qualified-data-name+)

(defrule indexed-by
    := "INDEXED" "BY"? index-name+)

(defrule picture-clause
    := picture "IS"? picture-string
    :reduce `(:picture ,picture-string))

(defrule picture
    := "PICTURE"
    := "PIC")

(defrule sign-clause
    := sign-is? alt-leading-trailing separate-character?
    :reduce `(:separate-sign ,separate-character :sign-position ,alt-leading-trailing))

(defrule sign-is
    := "SIGN" "IS"?)

(defrule separate-character
    := "SEPARATE" "CHARACTER"?
    :reduce t)

(defrule alt-leading-trailing
    := "LEADING"
    :reduce :leading
    := "TRAILING"
    :reduce :trailing)

(defrule synchronized-clause
    := synchronized alt-left-right?
    :reduce `(:synchronized ,(if alt-left-right
                                 alt-left-right
                                 t)))

(defrule alt-left-right
    := "LEFT"
    :reduce :left
    := "RIGHT"
    :reduce :right)

(defrule synchronized
    := "SYNCHRONIZED"
    := "SYNC")

(defrule usage-clause
    := usage-is? usage
    :reduce (list :encoding usage))

(defrule usage-is
    := "USAGE" "IS"?)

(defrule usage
    := "BINARY"
    :reduce :binary
    := "COMP"
    :reduce :comp
    := "COMP-1"
    :reduce :comp1
    := "COMP-2"
    :reduce :comp2
    := "COMP-3"
    :reduce :comp3
    := "COMP-4"
    :reduce :comp4
    := "COMPUTATIONAL"
    :reduce :comp
    := "COMPUTATIONAL-1"
    :reduce :comp1
    := "COMPUTATIONAL-2"
    :reduce :comp2
    := "COMPUTATIONAL-3"
    :reduce :comp3
    := "COMPUTATIONAL-4"
    :reduce :comp4
    := "DISPLAY"
    :reduce :display
    := "DISPLAY-1"
    :reduce :display1
    := "INDEX"
    :reduce :index
    := "PACKED-DECIMAL"
    :reduce :packed-decimal
    := "POINTER"
    :reduce :pointer)

(defrule renames-clause
    := "RENAMES" qualified-data-name through-qualified-data-name?
    :reduce `(:renames ,qualified-data-name ,through-qualified-data-name))

(defrule through-qualified-data-name
    := through qualified-data-name
    :reduce qualified-data-name)

(defrule condition-value-clause
    := values-are literal-through-literal+)

(defrule through-literal
    := through literal)

(defrule literal-through-literal
    := literal through-literal?)

(defrule values-are
    := values are?)

(defrule procedure-division-head
    := "PROCEDURE" "DIVISION" using-phrase? ".")

(defrule procedure-division
    := procedure-division-head sentence+)

(defrule using-phrase
    := "USING" data-name+)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defrule declaratives
    := "DECLARATIVES" "." declaratives-content+ "END" "DECLARATIVES" ".")

(defrule declaratives-content
    := cobol-identifier "SECTION" "." use-statement "." sentence*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defrule paragraph-header
    := cobol-identifier "SECTION"?
    :reduce (list (if $2 :section :label) $1))

(defrule sentence
    := declaratives
    := statement* "."
    :reduce $1
    := paragraph-header "."
    :reduce $1)

(defrule statement
    := move-statement
    := if-statement
    := perform-statement
    := go-to-statement
    := accept-statement
    := add-statement
    := alter-statement
    := call-statement
    := cancel-statement
    := close-statement
    := compute-statement
    := continue-statement
    := delete-statement
    := display-statement
    := divide-statement
    := entry-statement
    := evaluate-statement
    := exit-program-statement
    := exit-statement
    := goback-statement
    := initialize-statement
    := inspect-statement
    := merge-statement
    := multiply-statement
    := open-statement
    := read-statement
    := release-statement
    := return-statement
    := rewrite-statement
    := search-statement
    := set-statement
    := sort-statement
    := start-statement
    := stop-statement
    := string-statement
    := subtract-statement
    := unstring-statement
    := write-statement
    := paragraph-header)

(defrule accept-statement
    := "ACCEPT" variable-identifier "FROM" date
    := "ACCEPT" variable-identifier "AT" screen-coordinates
    :reduce (apply #'list 'accept-at variable-identifier screen-coordinates)
    := "ACCEPT" variable-identifier from-environment-name?)

(defrule from-environment-name
    := "FROM" cobol-identifier)


(defrule date
    := "DATE"
    := "DAY"
    := "DAY-OF-WEEK"
    := "TIME")

(defrule add-statement
    := "ADD" id-or-lit+ to-id-or-lit? "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?
    := "ADD" id-or-lit+ "TO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?
    := "ADD" corresponding variable-identifier "TO" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?)

(defrule statement-list
    := statement+)

(defrule alter-statement
    := "ALTER" procedure-to-procedure+)

(defrule proceed-to
    := "PROCEED" "TO")

(defrule procedure-to-procedure
    := procedure-name "TO" proceed-to? procedure-name)

(defrule call-statement
    := "CALL" id-or-lit using-parameters? call-rest-phrase "END-CALL"?
    :reduce (list 'call id-or-lit (cons 'list using-parameters)))

(defrule by-reference
    := "BY"? "REFERENCE")

(defrule content-parameter-value
    := cobol-identifier
    := literal)

(defrule reference-parameter
    := by-reference? variable-identifier)

(defrule content-parameter
    := "BY"? "CONTENT" content-parameter-value+)

(defrule parameter
    := reference-parameter
    := content-parameter
    := literal)

(defrule using-parameters
    := "USING" parameter+)

(defrule call-rest-phrase
    := on-exception-statement-list? not-on-exception-statement-list? on-overflow-statement-list?)

(defrule on-exception-statement-list
    := "ON"? "EXCEPTION" statement-list)

(defrule not-on-exception-statement-list
    := "NOT" "ON"? "EXCEPTION" statement-list)

(defrule cancel-statement
    := "CANCEL" id-or-lit+)

(defrule close-statement
    := "CLOSE" close-statement-file-name+
    :reduce (list 'close close-statement-file-name))

(defrule alt-removal-no-rewind
    := for-removal
    := with-no-rewind)

(defrule alt-reel-unit
    := "REEL"
    := "UNIT")

(defrule alt-no-rewind-lock
    := no-rewind
    := "LOCK")

(defrule close-statement-options-1
    := alt-reel-unit alt-removal-no-rewind?)

(defrule close-statement-options-2
    := "WITH"? alt-no-rewind-lock)

(defrule close-statement-options
    := close-statement-options-1
    := close-statement-options-2)

(defrule close-statement-file-name
    := file-name close-statement-options?)

(defrule compute-statement
    := "COMPUTE" cobword-rounded+ equal arithmetic-expression on-size-error-statement-list? not-on-size-error-statement-list? "END-COMPUTE"?
    :reduce (list 'compute cobword-rounded arithmetic-expression :on-size-error on-size-error-statement-list
                  :not-on-size-error not-on-size-error-statement-list))

(defrule equal
    := "="
    := "EQUAL")

(defrule continue-statement
    := "CONTINUE")

(defrule delete-statement
    := "DELETE" file-name "RECORD"? invalid-key-statement-list? not-invalid-key-statement-list? "END-DELETE"?
    :reduce (list 'delete file-name :invalid invalid-key-statement-list :not-invalid not-invalid-key-statement-list))

(defrule display-statement
    := "DISPLAY" id-or-lit+ upon-environment-name? with-no-advancing?
    :reduce (list 'display (cons 'list id-or-lit) :upon upon-environment-name :advance (not with-no-advancing))
    := "DISPLAY" id-or-lit "AT" screen-coordinates
    :reduce (apply #'list 'display-at id-or-lit screen-coordinates))

(defrule screen-coordinates
    := integer
    :reduce (multiple-value-list (truncate integer 100)))

(defrule upon-environment-name
    := "UPON" cobol-identifier)

(defrule with-no-advancing
    := "WITH"? "NO" "ADVANCING")

(defrule divide-statement
    := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
    := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
    := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
    := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
    := "DIVIDE" id-or-lit "INTO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?)

(defrule entry-statement
    := "ENTRY" literal using-phrase?)

(defrule evaluate-statement
    := "EVALUATE" evaluate-condition also-phrase* when-phrases+ when-other-phrase? "END-EVALUATE"?)

(defrule evaluate-condition
    := condition
    := "TRUE"
    := "FALSE")

(defrule also-phrase
    := "ALSO" evaluate-condition)

(defrule when-phrase-also-phrase
    := "ALSO" evaluate-phrase)

(defrule when-phrase
    := "WHEN" evaluate-phrase when-phrase-also-phrase*)

(defrule when-phrases
    := when-phrase+ statement-list)

(defrule when-other-phrase
    := "WHEN" "OTHER" statement-list)

(defrule evaluate-phrase
    := "ANY"
    := condition
    := "TRUE"
    := "FALSE"
    := evaluate-phrase-1)

(defrule evaluate-phrase-1
    := "NOT"? arithmetic-expression through-arithmetic-expression?)

(defrule through-arithmetic-expression
    := through arithmetic-expression)

(defrule exit-statement
    := "EXIT"
    :reduce '(exit-paragraph))

(defrule exit-program-statement
    := "EXIT" "PROGRAM"
    :reduce '(exit-program))

(defrule goback-statement
    := "GOBACK"
    :reduce '(go-back))

(defrule go-to-statement
    := "GO" "TO"? procedure-name+ "DEPENDING" "ON"? variable-identifier
    :reduce (list 'goto-depending variable-identifier procedure-name)
    := "GO" "TO"? procedure-name
    :reduce (list 'goto procedure-name))

(defrule if-phrase
    := "IF" condition "THEN"? alt-statement-list-next-sentence "ELSE" alt-statement-list-next-sentence
    :reduce (list 'if condition
                  (if (cdr alt-statement-list-next-sentence)
                      (cons 'progn alt-statement-list-next-sentence)
                      (car alt-statement-list-next-sentence))
                  (if (cdr alt-statement-list-next-sentence2)
                      (cons 'progn alt-statement-list-next-sentence2)
                      (car alt-statement-list-next-sentence2)))
    := "IF" condition "THEN"? alt-statement-list-next-sentence
    :reduce (append (list 'when condition) alt-statement-list-next-sentence))

(defrule if-statement
    := if-phrase "END-IF"?
    :reduce $1)

(defrule initialize-statement
    := "INITIALIZE" variable-identifier+ initialize-replacing-phrase?)

(defrule initialize-replacing-type
    := "ALPHABETIC"
    := "ALPHANUMERIC"
    := "NUMERIC"
    := "ALPHANUMERIC-EDITED"
    := "NUMERIC-EDITED"
    := "DBCS"
    := "EGCS")

(defrule initialize-replacing-argument
    := initialize-replacing-type "DATA"? "BY" id-or-lit)

(defrule initialize-replacing-phrase
    := "REPLACING" initialize-replacing-argument+)

(defrule inspect-statement
    := inspect-statement-1
    := inspect-statement-2
    := inspect-statement-3
    := inspect-statement-4)

(defrule inspect-statement-1
    := "INSPECT" variable-identifier "TALLYING" tallying-argument+)

(defrule inspect-statement-2
    := "INSPECT" variable-identifier "CONVERTING" id-or-lit "TO" id-or-lit before-after-phrase*)

(defrule inspect-statement-3
    := "INSPECT" variable-identifier "TALLYING" tallying-argument+ "REPLACING" inspect-replacing-phrase+)

(defrule tallying-for-id-or-lit
    := id-or-lit before-after-phrase*)

(defrule alt-all-leading
    := "ALL"
    := "LEADING")

(defrule tallying-for-argument-1
    := "CHARACTERS" before-after-phrase*)

(defrule tallying-for-argument-2
    := alt-all-leading tallying-for-id-or-lit+)

(defrule tallying-for-argument
    := tallying-for-argument-1
    := tallying-for-argument-2)

(defrule tallying-argument
    := variable-identifier "FOR" tallying-for-argument+)

(defrule inspect-statement-4
    := "INSPECT" variable-identifier "REPLACING" inspect-replacing-phrase+)

(defrule inspect-replacing-argument
    := inspect-by-argument "BY" inspect-by-argument before-after-phrase*)

(defrule alt-all-leading-first
    := "ALL"
    := "LEADING"
    := "FIRST")

(defrule inspect-replacing-phrase-1
    := "CHARACTERS" "BY" id-or-lit before-after-phrase*)

(defrule inspect-replacing-phrase-2
    := alt-all-leading-first inspect-replacing-argument+)

(defrule inspect-replacing-phrase
    := inspect-replacing-phrase-1
    := inspect-replacing-phrase-2)

(defrule before-after-phrase
    := alt-before-after "INITIAL"? id-or-lit)

(defrule merge-statement
    := "MERGE" file-name on-key-phrase+ collating-sequence? "USING" file-name file-name+ merge-statement-tail)

(defrule on-key-phrase
    := "ON"? alt-ascending-descending "KEY"? qualified-data-name+)

(defrule merge-statement-tail
    := output-procedure
    := giving-file-names)

(defrule move-statement
    := "MOVE" id-or-lit "TO" variable-identifier+
    :reduce (apply #'list 'move id-or-lit variable-identifier)
    := "MOVE" corresponding variable-identifier "TO" variable-identifier+
    :reduce (apply #'list 'move-corresponding variable-identifier variable-identifier2))

(defrule multiply-statement
    := "MULTIPLY" id-or-lit "BY" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"?
    :reduce (list 'multiply id-or-lit cobword-rounded :on-size-error on-size-error-statement-list
                  :not-on-size-error not-on-size-error-statement-list)
    := "MULTIPLY" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"?
    :reduce (list 'multiply id-or-lit id-or-lit2 :giving cobword-rounded
                  :on-size-error on-size-error-statement-list
                  :not-on-size-error not-on-size-error-statement-list))

(defrule open-statement
    := "OPEN" open-statement-phrase+
    :reduce (list 'open open-statement-phrase))

(defrule alt-reversed-with-no-rewind
    := "REVERSED"
    := with-no-rewind)

(defrule open-statement-input-file-name
    := file-name alt-reversed-with-no-rewind?)

(defrule with-no-rewind
    := "WITH"? "NO" "REWIND")

(defrule open-statement-output-file-name
    := file-name with-no-rewind?)

(defrule open-statement-input
    := "INPUT" open-statement-input-file-name+)

(defrule open-statement-output
    := "OUTPUT" open-statement-output-file-name+)

(defrule open-statement-i-o
    := "I-O" file-name+)

(defrule open-statement-extend
    := "EXTEND" file-name+)

(defrule open-statement-phrase
    := open-statement-input
    := open-statement-output
    := open-statement-i-o
    := open-statement-extend)

(defrule perform-statement
    := "PERFORM" procedure-name through-procedure-name? perform-until-phrase
    :reduce `(perform-until ,procedure-name ,through-procedure-name ,perform-until-phrase)
    := "PERFORM" procedure-name through-procedure-name? perform-varying-phrase perform-after-phrase*
    :reduce `(perform-varying ,perform-varying-phrase ,procedure-name ,through-procedure-name ,perform-after-phrase)
    := "PERFORM" procedure-name through-procedure-name? cobword-int "TIMES"
    :reduce `(perform-times ,cobword-int ,procedure-name ,through-procedure-name)
    := "PERFORM" procedure-name through-procedure-name?
    :reduce (append (list 'perform procedure-name) through-procedure-name))

(defrule perform-varying-phrase
    := with-test? "VARYING" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition)

(defrule perform-after-phrase
    := "AFTER" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition)

(defrule perform-until-phrase
    := with-test? "UNTIL" condition)

(defrule with-test
    := "WITH"? "TEST" alt-before-after
    :reduce alt-before-after)

(defrule read-statement
    := "READ" file-name "NEXT"? "RECORD"? into-identifier? key-is-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? at-end-statement-list? not-at-end-statement-list? "END-READ"?)

(defrule key-is-qualified-data-name
    := "KEY" "IS"? qualified-data-name)

(defrule release-statement
    := "RELEASE" record-name from-identifier?)

(defrule return-statement
    := "RETURN" file-name "RECORD"? into-identifier? "AT"? "END" statement-list not-at-end-statement-list? "END-RETURN"?)

(defrule into-identifier
    := "INTO" variable-identifier)

(defrule not-at-end-statement-list
    := "NOT" "AT"? "END" statement-list)

(defrule rewrite-statement
    := "REWRITE" record-name from-identifier? invalid-key-statement-list? not-invalid-key-statement-list? "END-REWRITE"?)

(defrule search-statement
    := search-statement-1
    := search-statement-2)

(defrule search-statement-1
    := "SEARCH" cobol-identifier varying-identifier? at-end-statement-list? when-condition-stats+ "END-SEARCH"?)

(defrule varying-identifier
    := "VARYING" variable-identifier)

(defrule when-condition-stats
    := "WHEN" condition alt-statement-list-next-sentence)

(defrule search-statement-2
    := "SEARCH" "ALL" variable-identifier at-end-statement-list? "WHEN" search-statement-condition search-statement-condition-tail* alt-statement-list-next-sentence "END-SEARCH"?)

(defrule at-end-statement-list
    := "AT"? "END" statement-list)

(defrule search-statement-equal-expression
    := variable-identifier "IS"? equal-to arithmetic-expression
    :reduce (list '= variable-identifier arithmetic-expression))

(defrule search-statement-condition
    := search-statement-equal-expression
    := condition-name-reference)

(defrule search-statement-condition-tail
    := "AND" search-statement-condition)

(defrule alt-statement-list-next-sentence
    := statement+
    := next-sentence
    :reduce :next-sentence)

(defrule set-statement
    := "SET" set-statement-phrase+)

(defrule sort-statement
    := "SORT" file-name on-key-is-phrase+ with-duplicates-in-order? collating-sequence? sort-statement-in sort-statement-out)

(defrule key-is
    := "KEY" "IS"?)

(defrule alt-ascending-descending
    := "ASCENDING"
    := "DESCENDING")

(defrule on-key-is-phrase
    := "ON"? alt-ascending-descending key-is? qualified-data-name+)

(defrule with-duplicates-in-order
    := "WITH"? "DUPLICATES" "IN"? "ORDER"?)

(defrule collating-sequence
    := "COLLATING"? "SEQUENCE" "IS"? alphabet-name)

(defrule through
    := "THROUGH"
    := "THRU")

(defrule through-procedure-name
    := through procedure-name
    :reduce procedure-name)

(defrule using-file-names
    := "USING" file-name+)

(defrule input-procedure
    := "INPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?)

(defrule giving-file-names
    := "GIVING" file-name+)

(defrule output-procedure
    := "OUTPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?)

(defrule sort-statement-in
    := using-file-names
    := input-procedure)

(defrule sort-statement-out
    := giving-file-names
    := output-procedure)

(defrule start-statement
    := "START" file-name key-is-rel-op-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? "END-START"?)

(defrule rel-op
    := equal-to
    :reduce '=
    := greater-than
    :reduce '>
    := greater-equal
    :reduce '>=)

(defrule key-is-rel-op-qualified-data-name
    := "KEY" "IS"? rel-op qualified-data-name
    :reduce (list rel-op qualified-data-name))

(defrule stop-statement
    := "STOP" alt-run-literal
    :reduce '(stop))

(defrule alt-run-literal
    := "RUN"
    := literal)

(defrule string-statement
    := "STRING" delimited-by-phrase+ "INTO" variable-identifier with-pointer-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-STRING"?
    :reduce (list 'string-concat delimited-by-phrase variable-identifier :with-pointer with-pointer-identifier :on-overflow on-overflow-statement-list :not-on-overflow not-on-overflow-statement-list))

(defrule id-or-lit-size
    := literal
    := variable-identifier
    := "SIZE")

(defrule delimited-by-phrase
    := id-or-lit+ "DELIMITED" "BY"? id-or-lit-size
    :reduce (list id-or-lit id-or-lit-size))

(defrule subtract-statement
    := "SUBTRACT" id-or-lit+ "FROM" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"?
    :reduce (list 'subtract-giving id-or-lit id-or-lit2 cobword-rounded
                  :on-size-error on-size-error-statement-list
                  :not-on-size-error not-on-size-error-statement-list)
    := "SUBTRACT" id-or-lit+ "FROM" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"?
    :reduce (list 'subtract id-or-lit cobword-rounded
                  :on-size-error on-size-error-statement-list
                  :not-on-size-error not-on-size-error-statement-list)
    := "SUBTRACT" corresponding variable-identifier "FROM" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"?
    :reduce (list 'subtract-corr variable-identifier variable-identifier
                  :rounded (and $5 t)
                  :on-size-error on-size-error-statement-list
                  :not-on-size-error not-on-size-error-statement-list))

(defrule cobword-rounded
    := variable-identifier "ROUNDED"?
    :reduce (list variable-identifier (and $2 t)))

(defrule on-size-error-statement-list
    := "ON"? "SIZE" "ERROR" statement-list
    :reduce statement-list)

(defrule not-on-size-error-statement-list
    := "NOT" "ON"? "SIZE" "ERROR" statement-list
    :reduce statement-list)

(defrule corresponding
    := "CORRESPONDING"
    := "CORR")

(defrule unstring-statement
    := "UNSTRING" variable-identifier delimited-by-all-phrase? "INTO" unstring-statement-dst+ with-pointer-identifier? tallying-in-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-UNSTRING"?
    :reduce (list 'unstring variable-identifier unstring-statement-dst
                  :delimited-by-all delimited-by-all-phrase
                  :with-pointer with-pointer-identifier
                  :tallying tallying-in-identifier
                  :on-overflow on-overflow-statement-list
                  :not-on-overflow not-on-overflow-statement-list))

(defrule id-or-lit
    := literal
    := variable-identifier)

(defrule or-all-id-or-lit
    := "OR" "ALL"? id-or-lit)

(defrule delimited-by-all-phrase
    := "DELIMITED" "BY"? "ALL"? id-or-lit or-all-id-or-lit*)

(defrule delimiter-in-identifier
    := "DELIMITER" "IN"? variable-identifier)

(defrule count-in-identifier
    := "COUNT" "IN"? variable-identifier)

(defrule unstring-statement-dst
    := variable-identifier delimiter-in-identifier? count-in-identifier?)

(defrule with-pointer-identifier
    := "WITH"? "POINTER" variable-identifier)

(defrule tallying-in-identifier
    := "TALLYING" "IN"? variable-identifier)

(defrule on-overflow-statement-list
    := "ON"? "OVERFLOW" statement-list)

(defrule not-on-overflow-statement-list
    := "NOT" "ON"? "OVERFLOW" statement-list)

(defrule write-statement
    := "WRITE" record-name from-identifier? advancing-phrase? write-exceptions "END-WRITE"?)

(defrule lines
    := "LINE"
    := "LINES")

(defrule cobword-int
    := cobol-identifier
    := integer)

(defrule nr-lines-phrase
    := cobword-int lines?)

(defrule page-phrase
    := nr-lines-phrase
    := "PAGE")

(defrule alt-before-after
    := "BEFORE"
    := "AFTER")

(defrule advancing-phrase
    := alt-before-after "ADVANCING"? page-phrase)

(defrule from-identifier
    := "FROM" variable-identifier)

(defrule invalid-key-statement-list
    := "INVALID" "KEY"? statement-list
    :reduce statement-list)

(defrule not-invalid-key-statement-list
    := "NOT" "INVALID" "KEY"? statement-list
    :reduce statement-list)

(defrule end-of-page
    := "END-OF-PAGE"
    := "EOP")

(defrule at-end-of-page-statement-list
    := "AT"? end-of-page statement-list
    :reduce statement-list)

(defrule not-at-end-of-page-statement-list
    := "NOT" "AT"? end-of-page statement-list
    :reduce statement-list)

;; This is left in the grammar but is not used.  COPYs are handled by
;; the lexical scanner.
(defrule copy-statement
    := "COPY" alt-text-name-literal in-library? "SUPPRESS"? copy-statement-replacing-phrase?)

(defrule in
    := "OF"
    := "IN")

(defrule alt-library-name-literal
    := library-name
    := literal)

(defrule in-library
    := in alt-library-name-literal)

(defrule copy-statement-by-phrase
    := copy-operand "BY" copy-operand)

(defrule copy-statement-replacing-phrase
    := "REPLACING" copy-statement-by-phrase+)

(defrule alt-text-name-literal
    := text-name
    := literal)

(defrule copy-operand
    := cobol-identifier
    := literal)

(defrule use-statement
    := use-statement-1
    := use-statement-2
    := use-statement-3)

(defrule use-statement-1
    := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-exception-error "PROCEDURE" "ON"? alt-file-names-i-o)

(defrule alt-exception-error
    := "EXCEPTION"
    := "ERROR")

(defrule use-statement-2
    := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-beginning-ending? alt-file-reel-unit? "LABEL" "PROCEDURE" "ON"? alt-file-names-i-o)

(defrule alt-beginning-ending
    := "BEGINNING"
    := "ENDING")

(defrule alt-file-reel-unit
    := "FILE"
    := "REEL"
    := "UNIT")

(defrule file-names
    := file-name+)

(defrule alt-file-names-i-o
    := file-names
    := "INPUT"
    := "OUTPUT"
    := "I-O"
    := "EXTEND")

(defrule use-statement-3
    := "USE" "FOR"? "DEBUGGING" "ON"? alt-procedures-all-procedures)

(defrule procedure-names
    := procedure-name+)

(defrule alt-procedures-all-procedures
    := procedure-names
    := all-procedures)

(defrule condition
    := combinable-condition
    := combinable-condition "AND" condition
    :reduce `(and ,combinable-condition ,condition)
    := combinable-condition "OR" condition
    :reduce `(or ,combinable-condition ,condition)
    := combinable-condition "AND" id-or-lit
    :reduce `(and ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit))
    := combinable-condition "OR" id-or-lit
    :reduce `(or ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit)))

(defrule combinable-condition
    := "NOT"? simple-condition
    :reduce (if $1
                (list 'not simple-condition)
                simple-condition))

(defrule simple-condition
    := class-condition
    := relation-condition
    := sign-condition
    := "(" condition ")"
    ;; not sure if it's necessary -wcp15/7/03.
    ;; := arithmetic-expression
    )

(defrule class-condition
    := variable-identifier "IS"? "NOT"? class-type
    :reduce (if $3
                (list 'not (list 'type-of variable-identifier (make-keyword class-type)))
                (list 'type-of variable-identifier (make-keyword class-type))))

(defrule class-type
    := "NUMERIC"
    := "ALPHABETIC"
    := "ALPHABETIC-LOWER"
    := "ALPHABETIC-UPPER"
    := "DBCS")

(defun unfold-subrelations (main-relation subs)
  (destructuring-bind (main-operator main-variable other-variable) main-relation
    (declare (ignore other-variable))
    (labels ((unfold (subs)
               (if (null subs)
                   main-relation
                   (destructuring-bind (connection operator variable) (car subs)
                     (list connection
                           (list (or operator main-operator) main-variable variable)
                           (unfold (cdr subs)))))))
      (unfold subs))))

(defrule relation-condition
    ;; This is too complex
    ;; := arithmetic-expression relational-operator simple-condition
    := id-or-lit relational-operator id-or-lit subordinate-relation*
    :reduce (unfold-subrelations (list relational-operator id-or-lit id-or-lit2) subordinate-relation))

(defrule or-and
    := "OR" :reduce 'or
    := "AND" :reduce 'and)

(defrule subordinate-relation
    := or-and relational-operator? id-or-lit
    :reduce (list or-and relational-operator id-or-lit))

(defrule relational-operator
    := "IS"? relational-operator-type
    :reduce relational-operator-type)

(defrule less-than
    := "LESS" "THAN"?
    := "<")

(defrule greater-equal
    := "GREATER" "THAN"? "OR" "EQUAL" "TO"?
    := ">="
    := ">" "="
    := "NOT" "<"
    := "NOT" "LESS" "THAN"?)

(defrule less-equal
    := "LESS" "THAN"? "OR" "EQUAL" "TO"?
    := "<="
    := "<" "="
    := "NOT" ">"
    := "NOT" "GREATER" "THAN"?)

(defrule greater-than
    := "GREATER" "THAN"?
    := ">")

(defrule equal-to
    := "EQUAL" "TO"?
    := "=")

(defrule relational-operator-type
    := greater-equal
    :reduce 'cob>=
    := less-equal
    :reduce 'cob<=
    := greater-than
    :reduce 'cob>
    := less-than
    :reduce 'cob<
    := equal-to
    :reduce 'cob=
    := "NOT" equal-to
    :reduce 'cob-not=)

(defrule sign-condition
    := arithmetic-expression "IS"? "NOT"? sign-type
    :reduce (if $3
                `(not (,sign-type ,arithmetic-expression))
                `(,sign-type ,arithmetic-expression)))

(defrule sign-type
    := "POSITIVE" :reduce '>
    := "NEGATIVE" :reduce '<
    := "ZERO" :reduce '=
    := "ZEROES" :reduce '=
    := "ZEROS" :reduce '=)

(defrule procedure-name
    := paragraph-or-section-name in-section-name
    :reduce (list paragraph-or-section-name in-section-name)
    := paragraph-or-section-name
    :reduce paragraph-or-section-name)

(defrule in-section-name
    := in cobol-identifier
    :reduce cobol-identifier)

(defrule variable-identifier
    := qualified-data-name subscript-parentheses* ;; reference-modification?
    :reduce (if subscript-parentheses
                (list :aref qualified-data-name subscript-parentheses)
                qualified-data-name))

(defrule reference-modification
    := "(" leftmost-character-position ":" length? ")"
    :reduce (if length
                (list :range leftmost-character-position length)
                leftmost-character-position))

(defrule condition-name-reference
    := condition-name in-data-or-file-or-mnemonic-name* subscript-parentheses*)

(defrule in-data-or-file-or-mnemonic-name
    := in data-or-file-or-mnemonic-name)

(defrule subscript-parentheses
    := "(" subscript ")")

(defrule subscript
    := subscript-expression+)

(defrule plus-minus-integer
    := plus-or-minus integer)

(defrule subscript-expression-ambiguous
    := qualified-data-name plus-minus-integer?)

(defrule subscript-expression
    := literal
    := subscript-expression-ambiguous)

(defrule qualified-data-name
    := data-name in-data-or-file-name*
    :reduce (if in-data-or-file-name
                (list data-name in-data-or-file-name) ; incomplete -wcp15/7/03.
                data-name)
    := "ADDRESS" "OF" data-name
    :reduce (list 'address-of data-name)
    := "LENGTH" "OF" cobol-identifier
    :reduce (list 'length-of cobol-identifier))

(defrule in-data-or-file-name
    := in data-or-file-name)

(defrule leftmost-character-position
    := arithmetic-expression)

(defrule length
    := arithmetic-expression)

(defrule arithmetic-expression
    := times-div
    := times-div "+" arithmetic-expression
    :reduce `(+ ,times-div ,arithmetic-expression)
    := times-div "-" arithmetic-expression
    :reduce `(- ,times-div ,arithmetic-expression))

(defrule times-div
    := power
    := power "*" times-div
    :reduce `(* ,power ,times-div)
    := power "/" times-div
    :reduce `(/ ,power ,times-div))

(defrule power
    := plus-or-minus? basis
    := plus-or-minus? basis "**" power
    :reduce (if plus-or-minus
                `(plus-or-minus (expt basis basis2))
                `(expt basis basis2)))

(defrule plus-or-minus
    := "+"
    :reduce '+
    := "-"
    :reduce '-)

;; (defrule power-tail
;;     := "**" basis)

(defrule basis
    := literal
    := variable-identifier
    := "(" arithmetic-expression ")")

(defrule alphabet-name
    := cobol-identifier)

(defrule condition-name
    := cobol-identifier)

(defrule data-name
    := cobol-identifier)

(defrule cobol-identifier
    := identifier
    :reduce (intern (string-upcase identifier)))

(defrule file-name
    := cobol-identifier)

(defrule data-or-file-name
    := cobol-identifier)

(defrule index-name
    := cobol-identifier)

(defrule mnemonic-name
    := cobol-identifier)

(defrule data-or-file-or-mnemonic-name
    := cobol-identifier)

(defrule record-name
    := qualified-data-name)

(defrule symbolic-character
    := cobol-identifier)

(defrule library-name
    := cobol-identifier)

(defrule program-name
    := cobol-identifier
    := string)

(defrule text-name
    := cobol-identifier)

(defrule paragraph-or-section-name
    := cobol-identifier
    := integer)

(defrule computer-name
    := identifier)

(defrule environment-name
    := cobol-identifier)

(defrule assignment-name
    := cobol-identifier)

(defrule figurative-constant
    := figurative-constant-simple
    := figurative-constant-all)

(defrule figurative-constant-all
    := "ALL" literal)

(defrule literal
    := string
    := float
    := integer
    := figurative-constant)

)					; defun populate-grammar