;; Modified to remove the calls of DO-MUTUAL, which are now commented out.
;; The forms below them in capital letters are presumably the ones that DO-MUTUAL
;; generated.
; *************************************
;  Functions on Integers and Rationals
; *************************************
; integer and rational libraries

Event: Start with the library "r2".

Definition: ipower (x, e) = if e ≃ 0 then 1

else itimes (x, ipower (x, e − 1)) endif

Definition: rpower (x, e) = if e ≃ 0 then rational (1, 1)

else rtimes (x, rpower (x, e − 1)) endif

Definition: rleq (x, y) = (rlessp (x, y) ∨ requal (x, y))

;; *****************
;;  ASCII characters
;; *****************

Definition: ascii nul = 0

Definition: ascii soh = 1

Definition: ascii stx = 2

Definition: ascii etx = 3

Definition: ascii eot = 4

Definition: ascii enq = 5

Definition: ascii ack = 6

Definition: ascii bel = 7

Definition: ascii bs = 8 Definition: ascii ht = 9 Definition: ascii lf = 10 Definition: ascii vt = 11 Definition: ascii ff = 12 Definition: ascii cr = 13 Definition: ascii so = 14 Definition: ascii si = 15 Definition: ascii dle = 16 Definition: ascii dc1 = 17 Definition: ascii dc2 = 18 Definition: ascii dc3 = 19 Definition: ascii dc4 = 20 Definition: ascii nak = 21 Definition: ascii syn = 22 Definition: ascii etb = 23 Definition: ascii can = 24 Definition: ascii em = 25 Definition: ascii sub = 26 Definition: ascii esc = 27 Definition: ascii fs = 28 Definition: ascii gs = 29 Definition: ascii rs = 30 Definition: ascii us = 31 Definition: ascii space = 32 Definition: ascii exclamation point = 33 Definition: ascii double quote = 34 Definition: ascii number sign = 35 Definition: ascii dollar = 36 Definition: ascii percent = 37 Definition: ascii and = 38 Definition: ascii single quote = 39 Definition: ascii open paren = 40 Definition: ascii close paren = 41 Definition: ascii star = 42 Definition: ascii plus = 43 Definition: ascii comma = 44 Definition: ascii dash = 45 Definition: ascii dot = 46 Definition: ascii slash = 47 Definition: ascii 0 = 48 Definition: ascii 1 = 49 Definition: ascii 2 = 50 Definition: ascii 3 = 51 Definition: ascii 4 = 52 Definition: ascii 5 = 53 Definition: ascii 6 = 54 Definition: ascii 7 = 55 Definition: ascii 8 = 56 Definition: ascii 9 = 57 Definition: ascii colon = 58 Definition: ascii semicolon = 59 Definition: ascii lt = 60 Definition: ascii equal = 61 Definition: ascii gt = 62 Definition: ascii question = 63 Definition: ascii at = 64 Definition: ascii a = 65 Definition: ascii b = 66 Definition: ascii c = 67 Definition: ascii d = 68 Definition: ascii e = 69 Definition: ascii f = 70 Definition: ascii g = 71 Definition: ascii h = 72 Definition: ascii i = 73 Definition: ascii j = 74 Definition: ascii k = 75 Definition: ascii l = 76 Definition: ascii m = 77 Definition: ascii n = 78 Definition: ascii o = 79 Definition: ascii p = 80 Definition: ascii q = 81 Definition: ascii r = 82 Definition: ascii s = 83 Definition: ascii t = 84 Definition: ascii u = 85 Definition: ascii v = 86 Definition: ascii w = 87 Definition: ascii x = 88 Definition: ascii y = 89 Definition: ascii z = 90 Definition: ascii open bracket = 91 Definition: ascii backslash = 92 Definition: ascii close bracket = 93 Definition: ascii caret = 94 Definition: ascii underscore = 95 Definition: ascii back quote = 96 Definition: ascii lc a = 97 Definition: ascii lc b = 98 Definition: ascii lc c = 99 Definition: ascii lc d = 100 Definition: ascii lc e = 101 Definition: ascii lc f = 102 Definition: ascii lc g = 103 Definition: ascii lc h = 104 Definition: ascii lc i = 105 Definition: ascii lc j = 106 Definition: ascii lc k = 107 Definition: ascii lc l = 108 Definition: ascii lc m = 109 Definition: ascii lc n = 110 Definition: ascii lc o = 111 Definition: ascii lc p = 112 Definition: ascii lc q = 113 Definition: ascii lc r = 114 Definition: ascii lc s = 115 Definition: ascii lc t = 116 Definition: ascii lc u = 117 Definition: ascii lc v = 118 Definition: ascii lc w = 119 Definition: ascii lc x = 120 Definition: ascii lc y = 121 Definition: ascii lc z = 122 Definition: ascii open brace = 123 Definition: ascii vertical bar = 124 Definition: ascii close brace = 125 Definition: ascii tilde = 126 Definition: ascii del = 127

;; ***********
;;  Utilities
;; ***********
; ---------------------------------
;  ASCII character (list) utilities
; ---------------------------------

Definition: ascii characterp (c) = ((c ∈ N) ∧ (0 ≤ c) ∧ (c ≤ 127))

Definition: ascii character listp (x) = if x ≃ nil then x = 0

else ascii characterp (car (x))

∧ ascii character listp (cdr (x)) endif

Definition: is digit (x) = ((x ∈ N) ∧ (ascii 0 ≤ x) ∧ (x ≤ ascii 9))

Definition: is letter (x) = ((x ∈ N)

∧ (((ascii a ≤ x) ∧ (x ≤ ascii z)) ∨ ((ascii lc a ≤ x) ∧ (x ≤ ascii lc z))))

Definition: printable char ordp (x) = ((x ∈ N) ∧ (ascii space ≤ x) ∧ (x ≤ ascii tilde))

Definition: upper case (c) = if (ascii lc a ≤ c) ∧ (c ≤ ascii lc z) then c − 32

else c endif

Definition: uc list (u) = if u ≃ nil then u

else cons (upper case (car (u)), uc list (cdr (u))) endif

; ------------------
;  Number Utilities
; ------------------

Definition: number list2 (hi, lo, nl) = if hi ≃ 0 then cons (lo, nl)

else number list2 (hi − 1, lo, cons (iplus (hi, lo), nl)) endif

Definition: number list (lo, hi) = if ileq (lo, hi) then number list2 (idifference (hi, lo), lo, nil)

else nil endif Definition: number to char list (x) = if x ∈ N

then let q be x ÷ 10,

r be cons ((x mod 10) + ascii 0, 0) in if q ≃ 0 then r else append (number to char list (q), r) endif endlet

else nil endif

; ----------------
;  List Utilities
; ----------------

Definition: intersection (x, y) = if x ≃ nil then nil

elseif car (x) ∈ y then cons (car (x), intersection (cdr (x), y)) else intersection (cdr (x), y) endif

Definition: length (l) = if l ≃ nil then zero

else 1 + length (cdr (l)) endif

Definition: ncopies (n, x) = if n ≃ 0 then nil

else cons (x, ncopies (n − 1, x)) endif

Definition: nth (i, s) = if s ≃ nil then nil

elseif i = 1 then car (s) else nth (i − 1, cdr (s)) endif

Definition: rcar (x) = if x ≃ nil then nil

elseif cdr (x) ≃ nil then car (x)

else rcar (cdr (x)) endif

Definition: rcdr (x)

= if x ≃ nil then x elseif cdr (x) ≃ nil then cdr (x) else cons (car (x), rcdr (cdr (x))) endif

Theorem: lessp rcdr listp (s) → (count (rcdr (s)) < count (s))

Definition: rcons (x, y) = if x ≃ nil then cons (y, x)

else cons (car (x), rcons (cdr (x), y)) endif

Theorem: rcar rcons rcar (rcons (x, y)) = y

Theorem: rcdr rcons rcdr (rcons (x, y)) = x

Definition: remove (e, s) = if s ≃ nil then s

elseif car (s) = e then remove (e, cdr (s)) else cons (car (s), remove (e, cdr (s))) endif

Theorem: lessp remove length (e ∈ s) → (length (remove (e, s)) < length (s))

Definition: set difference (x, y) = if x ≃ nil then x

elseif car (x) ∈ y then set difference (cdr (x), y) else cons (car (x), set difference (cdr (x), y)) endif

Definition: subsetp (x, y) = if x ≃ nil then t

else (car (x) ∈ y) ∧ subsetp (cdr (x), y) endif

Definition: set equal (x, y) = (subsetp (x, y) ∧ subsetp (y, x))

; ****************
;  Key-Value Maps
; ****************

Definition: empty map = nil Definition: map entry (k, v) = cons (k, v)

Definition: in map (m, k) = assoc (k, m)

Definition: add to map (m, k, v) = if m ≃ nil then list (map entry (k, v))

elseif caar (m) = k then cons (map entry (k, v), cdr (m))

else cons (car (m), add to map (cdr (m), k, v)) endif

Definition: mapped value (m, k) = let v be assoc (k, m)

in

if listp (v) then cdr (v) else nil endif endlet

Definition: all matches (k, m) = if m ≃ nil then nil

elseif k = caar (m) then cons (cdar (m), all matches (k, cdr (m)))

else all matches (k, cdr (m)) endif

Definition: keys (x) = if x ≃ nil then nil

else cons (caar (x), keys (cdr (x))) endif

Definition: key values (x) = if x ≃ nil then nil

else cons (cdar (x), key values (cdr (x))) endif

Definition: key value mapp (m) = if m ≃ nil then m = nil

else listp (car (m)) ∧ key value mapp (cdr (m)) endif

Theorem: lessp keys (key value mapp (m) ∧ listp (m)) → (count (keys (m)) < count (m))

Theorem: lessp key values (key value mapp (m) ∧ listp (m)) → (count (key values (m)) < count (m))

Definition: pair list map (x, y) = if x ≃ nil then nil

else cons (map entry (car (x), car (y)), pair list map (cdr (x), cdr (y))) endif

; *******
;  Trees
; *******

Event: Add the shell mk tree, with recognizer function symbol treep and 2 accessors: root, with type restriction (none-of) and default value false; subtrees, with type restriction (none-of) and default value false.

; *****************************
;  Productions and Parse Trees
; *****************************
; A grammar symbol is a litatom, representing either a terminal or a
; nonterminal in the grammar.  A terminal grammar symbol is called a token.
; (prodn x y) is the representation of "x ::= y" and
; (lhs (prodn x y)) = x & (rhs (prodn x y)) = y.
;
; The left-hand-side (lhs) of a production (prodn) is a nonterminal grammar
; symbol.  The right-hand-side (rhs) of a production is either a grammar
; symbol or a list of grammar symbols.  The grammar symbols in a production
; may be tagged (see below).

Event: Add the shell prodn, with recognizer function symbol prodnp and 2 accessors: lhs, with type restriction (none-of) and default value false; rhs, with type restriction (none-of) and default value false.

; (tag grammar_symbol the_tag) constructs a tagged grammar symbol.
; (gsymbol (tag grammar_symbol the_tag)) = grammar_symbol and
; (label (tag grammar_symbol the_tag)) = the_tag.
;
; Grammar symbols in productions are tagged so that semantic functions can be
; converted mechanically to report form, where the tags are thought to clarify
; the presentation.

Event: Add the shell tag, with recognizer function symbol taggedp and 2 accessors: gsymbol, with type restriction (none-of) and default value false; label, with type restriction (none-of) and default value false.

; (mk_tree r s) is the representation of a parse tree and

; (root (mk_tree r s)) = r & (subtrees (mk_tree r s)) = s.
;
; The root of a parse tree is a grammar symbol, representing a terminal or a
; nonterminal.  Grammar symbols in parse trees are not tagged.  If the root
; represents a terminal, the parse tree is a leaf and its subtrees part is a
; representation of the lexeme that matched the terminal grammar symbol
; (token).  Otherwise, the root represents a nonterminal, and the subtrees
; part is a parse tree or a list of parse trees.

; ********************
;   Parse Tree Leaves
; ********************
; A leaf of a parse tree is a parse tree whose root is a terminal grammar
; symbol (token) and whose subtrees part is the list of characters (lexeme)
; that matched the token.  The last cdr of the character list should be zero,
; not nil.

Definition: reserved words

= '(adjoin all and append array assert assume await
      before begin behind binary block buffer case cblock
      centry cexit cobegin cond const decimal difference
      div each element elif else end entry eq exit extends
      fi from function ge give gt hex hold if iff imp input
      in into initially intersect is keep le leave lemma
      loop lt mapomit mapping mod move name ne new normal
      not octal of omit on or otherwise output pending
      procedure prove receive record remove scope send seq
      seqomit sequence set signal some sub then to type
      union unless var when with alias export import
      multiplecond none space string value)

Definition: special symbol map = list (cons ('and, cons (ascii and, 0)),

cons ('append, cons (ascii at, 0)),

cons ('close paren, cons (ascii close paren, 0)),

cons ('colon, cons (ascii colon, 0)),

cons ('colon equal, cons (ascii colon, cons (ascii equal, 0))), cons ('colon gt, cons (ascii colon, cons (ascii gt, 0))), cons ('comma, cons (ascii comma, 0)), cons ('dot, cons (ascii dot, 0)), cons ('dot dot, cons (ascii dot, cons (ascii dot, 0))), cons ('equal, cons (ascii equal, 0)), cons ('gt, cons (ascii gt, 0)), cons ('imp, cons (ascii dash, cons (ascii gt, 0))), cons ('lt, cons (ascii lt, 0)), cons ('lt colon, cons (ascii lt, cons (ascii colon, 0))), cons ('minus, cons (ascii dash, 0)), cons ('open paren, cons (ascii open paren, 0)), cons ('plus, cons (ascii plus, 0)), cons ('semi colon, cons (ascii semicolon, 0)), cons ('slash, cons (ascii slash, 0)), cons ('star, cons (ascii star, 0)), cons ('star star, cons (ascii star, cons (ascii star, 0))))

Definition: special symbols = keys (special symbol map)

Definition: tokens

= append ('(digit list identifier character value
             string value entry value),

reserved words ∪ special symbols)

Definition: tokenp (x) = (x ∈ tokens)

Definition: leafp (x) = (treep (x) ∧ tokenp (root (x)) ∧ ascii character listp (subtrees (x)))

Definition: lexeme (x) = if leafp (x) then subtrees (x)

else nil endif

; =========================
;  Recognizers for Lexemes
; =========================
; ----------------------
;  Reserved Word Lexeme
; ----------------------

Definition: reserved word lexemep (x) = (pack (uc list (x)) ∈ reserved words)

; -----------------------
;  Special Symbol Lexeme
; -----------------------

Definition: close bracket lexeme = cons (ascii close bracket, 0)

Definition: close paren lexeme = cons (ascii close paren, 0)

Definition: open bracket lexeme = cons (ascii open bracket, 0)

Definition: open paren lexeme = cons (ascii open paren, 0)

Definition: special symbol lexemes = append (list (open bracket lexeme, close bracket lexeme),

key values (special symbol map))

Definition: special symbol lexemep (x) = (x ∈ special symbol lexemes)

; ------------------------
;  Character Value Lexeme
; ------------------------

Definition: character value lexemep (x) = ((length (x) = 3)

∧ (car (x) = ascii single quote) ∧ printable char ordp (cadr (x)) ∧ (rcar (x) = ascii single quote) ∧ (cdddr (x) = 0))

; -------------------
;  Digit List Lexeme
; -------------------

Definition: is hexdigit (d) = (is digit (d)

∨ ((ascii a ≤ upper case (d)) ∧ (upper case (d) ≤ ascii f)))

Definition: is hexdigit list (x) = if x ≃ nil then x = 0

else is hexdigit (car (x)) ∧ is hexdigit list (cdr (x)) endif

Definition: digit list lexemep (x) = (listp (x) ∧ is digit (car (x)) ∧ is hexdigit list (cdr (x)))

; ------------------------------------
;  Entry Value and Identifier Lexemes
; ------------------------------------

Definition: identifier lexeme form (x) = if x ≃ nil then x = 0

elseif car (x) = ascii underscore

then listp (cdr (x))

∧ (cadr (x) ≠ ascii underscore) ∧ identifier lexeme form (cdr (x)) else (is letter (car (x)) ∨ is digit (car (x)))

∧ identifier lexeme form (cdr (x)) endif

Definition: identifier lexemep (x) = if listp (x)

then is letter (car (x))

∧ identifier lexeme form (x)

∧ (pack (uc list (x)) ∉ reserved words) else f endif

Definition: entry value lexemep (x) = (listp (x)

∧ identifier lexemep (rcdr (x))

∧ (rcar (x) = ascii single quote))

; ---------------------
;  String Value Lexeme
; ---------------------

Definition: string char listp (s)

= if s ≃ nil then s = 0 elseif car (s) = ascii double quote then listp (cdr (s))

∧ (cadr (s) = ascii double quote) ∧ string char listp (cddr (s))

else ascii characterp (car (s)) ∧ string char listp (cdr (s)) endif

Definition: string value lexemep (x) = ((length (x) ≥ 2)

∧ (car (x) = ascii double quote) ∧ (rcar (x) = ascii double quote) ∧ string char listp (rcdr (cdr (x))))

; ===================================
;  Recognizers for Parse Tree Leaves
; ===================================

Definition: reserved wordp (x) = (leafp (x)

∧ (root (x) ∈ reserved words)

∧ (uc list (lexeme (x)) = uc list (unpack (root (x)))))

Definition: special symbolp (x) = (leafp (x)

∧ (root (x) ∈ special symbols)

∧ case on root (x):

case = open paren then lexeme (x)

∈ list (open paren lexeme, open bracket lexeme) case = close paren then lexeme (x)

∈ list (close paren lexeme, close bracket lexeme) otherwise lexeme (x)

= mapped value (special symbol map, root (x)) endcase)

Definition: character valuep (x) = (leafp (x)

    ∧ (root (x) = 'character value)

∧ character value lexemep (lexeme (x)))

Definition: digit listp (x) = (leafp (x)

∧ (root (x) = 'digit list) ∧ digit list lexemep (lexeme (x)))

Definition: entry valuep (x) = (leafp (x)

    ∧ (root (x) = 'entry value)

∧ entry value lexemep (lexeme (x)))

Definition: identifierp (x) = (leafp (x)

    ∧ (root (x) = 'identifier)

∧ identifier lexemep (lexeme (x)))

Definition: string valuep (x) = (leafp (x)

    ∧ (root (x) = 'string value)

∧ string value lexemep (lexeme (x)))

; **********************************************
;  Relation between Parse Trees and Productions
; **********************************************
; ===================
;  The Gypsy Grammar
; ===================

Event: Introduce the function symbol gypsy grammar of 0 arguments.

; =============================================
;  First Rule Used in Derivation of Parse Tree
; =============================================

Definition: mk rhs (pt) = if treep (pt) then root (pt)

elseif listp (pt) then cons (mk rhs (car (pt)), mk rhs (cdr (pt))) else pt endif Definition: mk rule (pt) = if treep (pt) then prodn (root (pt), mk rhs (subtrees (pt)))

else nil endif

; =========================
;  Well-Formed Parse Trees
; =========================

Definition: parse tree leafp (pt) = if leafp (pt)

then case on root (pt): case = character value then character valuep (pt) case = digit list then digit listp (pt) case = entry value then entry valuep (pt) case = identifier then identifierp (pt) case = string value then string valuep (pt) otherwise reserved wordp (pt) ∨ special symbolp (pt) endcase

else f endif

Event: Disable tokenp.

Event: Disable parse tree leafp.

Event: Disable mk rule.

#|
(do-mutual '(
(defn parse_treep (pt)
  (if (treep pt)
      (if (tokenp (root pt))
  (parse_tree_leafp pt)
(and (litatom (root pt))
     (member (mk_rule pt) (Gypsy_grammar))
     (if (treep (subtrees pt))

 (parse_treep (subtrees pt))
       (parse_tree_listp (subtrees pt)))))
       ; & (correct_precedence_rule_application pt)
    F)
  ( (lessp (count pt)) ))
(defn parse_tree_listp (sts)
  (if (listp sts)
      (and (parse_treep (car sts))
   (parse_tree_listp (cdr sts)))
    (equal sts nil))
  ( (lessp (count sts)) ))
))
|#

Definition: mutual-parse tree listp-parse treep (mutual-flg, pt, sts)

= if mutual-flg = 'parse tree listp

then if listp (sts)

then mutual-parse tree listp-parse treep ('parse treep, car (sts), t)

∧ mutual-parse tree listp-parse treep ('parse tree listp, t, cdr (sts))

else sts = nil endif elseif treep (pt) then if tokenp (root (pt)) then parse tree leafp (pt)

else litatom (root (pt))

∧ (mk rule (pt) ∈ gypsy grammar)

∧ if treep (subtrees (pt))

then mutual-parse tree listp-parse treep ('parse treep, subtrees (pt), t)

else mutual-parse tree listp-parse treep ('parse tree listp, t, subtrees (pt)) endif endif

else f endif

Definition: parse tree listp (sts) = mutual-parse tree listp-parse treep ('parse tree listp, t, sts)

Definition: parse treep (pt) = mutual-parse tree listp-parse treep ('parse treep, pt, t)

Event: Enable tokenp.

Event: Enable parse tree leafp.

Event: Enable mk rule.

Conservative Axiom: pt intro (¬ parse treep (pt (s, nt))) → (pt (s, nt) = nil)

Simultaneously, we introduce the new function symbol pt.

; ================================
;  Parse Tree/Production Matching
; ================================

Definition: untag (pr) = if prodnp (pr) then prodn (untag (lhs (pr)), untag (rhs (pr)))

elseif taggedp (pr) then gsymbol (pr)

elseif listp (pr) then cons (untag (car (pr)), untag (cdr (pr))) else pr endif

Definition: rule (pt, pr) = (parse treep (pt)

∧ (mk rule (pt) = untag (pr))

∧ (untag (pr) ∈ gypsy grammar))

; ********************
;  Functions on trees
; ********************
; -----------
;  Tree Size
; -----------

Definition: tree size (x)

= if treep (x) then 1 + tree size (subtrees (x)) elseif listp (x) then 1 + (tree size (car (x)) + tree size (cdr (x))) else 0 endif

; ---------------
;  Tree Equality
; ---------------

Definition: leaf equal (t1 , t2 ) = if leafp (t1 ) ∧ leafp (t2 )

then (root (t1 ) = root (t2 )) ∧ if root (t1 )

              ∈ '(character value string value)

then lexeme (t1 ) = lexeme (t2 )

else uc list (lexeme (t1 )) = uc list (lexeme (t2 )) endif

else f endif

Definition: tree equal (t1 , t2 ) = if leafp (t1 ) then leaf equal (t1 , t2 )

elseif treep (t1 ) then treep (t2 )

∧ (root (t1 ) = root (t2 ))

∧ tree equal (subtrees (t1 ), subtrees (t2 )) elseif listp (t1 ) then listp (t2 )

∧ tree equal (car (t1 ), car (t2 )) ∧ tree equal (cdr (t1 ), cdr (t2 ))

else t1 = t2 endif

; ----------
;  Subtrees
; ----------

Definition: list subtree (x, n, i) = if x ≃ nil then nil

elseif treep (car (x)) ∧ (root (car (x)) = n)

then if i = 1 then car (x)

else list subtree (cdr (x), n, i − 1) endif else list subtree (cdr (x), n, i) endif Definition: subtree (x, n) = if treep (x)

then if treep (subtrees (x))

then if root (subtrees (x)) = n then subtrees (x)

else nil endif else list subtree (subtrees (x), n, 1) endif

else nil endif

Definition: subtree body (x, n) = if treep (subtree (x, n)) then subtrees (subtree (x, n))

else nil endif

Definition: subtree i (x, n, i) = if treep (x) then list subtree (subtrees (x), n, i)

else nil endif

Theorem: lessp list subtree size (tree size (list subtree (x, n, i)) ≠ 0) → (tree size (list subtree (x, n, i)) < tree size (x))

Theorem: lessp subtree size treep (x) → (tree size (subtree (x, n)) < tree size (x))

Theorem: lessp subtree i size treep (x) → (tree size (subtree i (x, n, i)) < tree size (x))

Theorem: tree size not zero treep (x) → (tree size (x) ≠ 0)

Theorem: lessp subtree body size treep (x) → (tree size (subtree body (x, n)) < tree size (x))

Theorem: rule imp treep rule (u, prodn (x, y)) → treep (u)

Theorem: rule imp lessp subtree size rule (u, prodn (x, y)) → (tree size (subtree (u, z)) < tree size (u))

Theorem: rule imp lessp subtree i size rule (u, prodn (x, y)) → (tree size (subtree i (u, z, i)) < tree size (u))

Definition: subtreep (t1 , t2 ) = if tree equal (t1 , t2 ) then t

elseif listp (t2 ) then subtreep (t1 , car (t2 )) ∨ subtreep (t1 , cdr (t2 )) elseif leafp (t2 ) then f elseif treep (t2 ) then subtreep (t1 , subtrees (t2 )) else f endif

; -------------------
;  Tree Substitution
; -------------------

Definition: subst tree (t1 , t2 , t3 ) = if tree equal (t2 , t3 ) then t1

elseif listp (t3 )

then cons (subst tree (t1 , t2 , car (t3 )), subst tree (t1 , t2 , cdr (t3 ))) elseif leafp (t3 ) then t3 elseif treep (t3 ) then mk tree (root (t3 ), subst tree (t1 , t2 , subtrees (t3 ))) else t3 endif

; *******************
;  Tree Constructors
; *******************
; --------
;  Leaves
; --------

Definition: mk reserved word (k) = if k ∈ reserved words then mk tree (k, unpack (k))

else nil endif

Definition: special symbol lexeme (x) = if in map (special symbol map, x)

then mapped value (special symbol map, x)

else nil endif

Definition: mk special symbol (x)

= let r be special symbol lexeme (x)

in

if listp (r) then mk tree (x, r)

else nil endif endlet

Definition: mk unary operator (x) = if x ∈ reserved words

then mk tree ('unary operator, mk reserved word (x))

else mk tree ('unary operator, mk special symbol (x)) endif

Definition: mk digit list (e) = if digit listp (e) then e

elseif e ∈ N then mk tree ('digit list, number to char list (e)) else mk tree ('digit list, e) endif

; Check e?

Definition: mk identifier lexeme (id) = let n be if litatom (id) then unpack (id)

else id endif

in

if n = unpack ('nil~) then unpack (nil) elseif identifier lexemep (n) then n else nil endif endlet

Definition: mk identifier (id) = if root (id) = 'identifier then id

else let n be mk identifier lexeme (id)

in

if identifier lexemep (n)

then mk tree ('identifier, n) else nil endif endlet endif

Definition: mk entry value lexeme (id) = let n1 be if litatom (id) then unpack (id)

else id endif

in

let n2 be if rcar (n1 ) = ascii single quote then mk identifier lexeme (rcdr (n1 ))

else mk identifier lexeme (n1 ) endif

in

if identifier lexemep (n2 )

then rcons (n2 , ascii single quote)

else nil endif endlet endlet

Definition: mk entry value (id) = if root (id) = 'entry value then id

elseif root (id) = 'identifier

then mk tree ('entry value, rcons (lexeme (id), ascii single quote)) else let n be mk entry value lexeme (id)

in

if entry value lexemep (n)

then mk tree ('entry value, n) else nil endif endlet endif

; need:  CHARACTER_VALUE STRING_VALUE

; ------------
;  Non-Leaves
; ------------

Definition: mk empty = mk tree ('empty, nil)

; Some (all?) of the following need work.

Definition: mk number (e) = if e ∈ N then mk tree ('number, mk digit list (e))

else mk tree ('number, e) endif

Definition: mk literal value (e) = if e ∈ N then mk tree ('literal value, mk number (e))

else mk tree ('literal value, e) endif

Definition: mk primary value (e) = if e ∈ N then mk tree ('primary value, mk literal value (e))

elseif litatom (e) then mk tree ('primary value, mk identifier (e)) else mk tree ('primary value, e) endif Definition: mk modified primary value (e) = mk tree ('modified primary value, mk primary value (e))

Definition: mk expression (e) = if (e ∈ N) ∨ litatom (e)

then mk tree ('expression, mk modified primary value (e)) else mk tree ('expression, e) endif

Definition: mk scalar const unit (n, v, q)

= mk tree ('constant declaration,

list (mk reserved word ('const), mk identifier (v), mk special symbol ('colon),

               mk tree ('type specification, n),

mk special symbol ('colon equal),

mk tree ('constant body, mk expression (q))))

Definition: mk named unit (u, s)

= mk tree ('name declaration,

list (mk reserved word ('name),

               mk tree ('local aliases, u),

mk reserved word ('from),

s))

Definition: mk single formal data parameter (a, p, ft)

= mk tree ('similar formal data parameters,
           list (mk tree ('opt access specification,

mk reserved word (a)),

               mk tree ('identifier list, p),

mk special symbol ('colon),

ft))

Definition: mk arg list (x) = mk tree ('arg list,

list (mk special symbol ('open paren), x, mk special symbol ('close paren)))

Definition: mk actual (n)

= mk tree ('expression,
           mk tree ('modified primary value,

mk tree ('primary value, mk identifier (n))))

Definition: mk actual list (as, n) = if as = nil then mk tree ('value list, mk actual (n))

else mk tree ('value list, list (as, mk special symbol ('comma), mk actual (n))) endif

Definition: namelist to actuals (ns, as) = if ns ≃ nil

then if as = nil then as

else mk arg list (as) endif else namelist to actuals (cdr (ns), mk actual list (as, car (ns))) endif

Definition: mk component selectors (x) = mk tree ('component selectors, x)

Definition: mk value modifiers (x) = if root (x) = 'arg list

then mk tree ('value modifiers, mk component selectors (x))

else mk tree ('value modifiers, x) endif

Definition: mk true expression

= mk tree ('expression,
           mk tree ('modified primary value,

mk primary value ('true)))

Definition: mk identifier list (is, i) = if is = nil then mk tree ('identifier list, i)

    else mk tree ('identifier list,

list (is, mk special symbol ('comma), i)) endif

Definition: mk bound expression (qn, ts, be)

= mk tree ('bound expression,

list (qn, mk special symbol ('colon), ts, mk special symbol ('comma), be))

Definition: mk quantified expression (qf , qn, ts, be)

= mk tree ('expression,

list (if litatom (qf ) then mk reserved word (qf ) else qf endif, mk bound expression (qn, ts, be)))

;; ********
;;  errors
;; ********

Definition: mk error (y) = mk tree ('error*, y)

Definition: mk error decl (y) = mk error (y)

Definition: errorp (x) = (treep (x) ∧ (root (x) = 'error*))

Definition: error msg (x) = if errorp (x) then subtrees (x)

    else '(no error message) endif

Definition: actual formal type error (a, ft) = mk error (list ('actual,

                'parameter,

a,

                'is,
                'not,
                'in,
                'formal,
                'type,

ft))

Definition: adjoin args error (v) = mk error (list ('cannot,

                'adjoin,
                'to,

v,

                'because,
                'it,
                'is,
                'not,
                'a,
                'set))

Definition: alias id error (i, sn) = mk error decl (cons (sn,

     append ('(is not the home scope of unit),

list (i))))

Definition: append args error (v1 , v2 ) = mk error (list ('append,

'is,
'not,
'defined,
'on,

v1 ,

'and,

v2 ,

'because,
'they,
'are,
'not,
'sequences))

Definition: array index error (id) = mk error (list ('array,

'index,
'type,

id,

'is,
'not,
'a,
'nonrational,
'simple,
'type))

Definition: bad string error (s)

= mk error (list (s, 'is, 'not, 'a, 'well formed, 'string))

Definition: bad value modifiers error (x)

= mk error (list ('ill formed, 'value modifiers, x))

Definition: character error (x) = mk error (list (x, 'is, 'not, 'a, 'character))

Definition: colon gt args error

= mk error ('(can colon gt only to sequences))

Definition: component assign error (x) = mk error (list ('components,

'of,
'value,

x,

'cannot,
'be,
'assigned))

Definition: condition params error (e) = mk error (list ('expression,

e,

'should,
'not,
'have,
'actual,
'condition,
'parameters))

Definition: difference args error (v1 , v2 ) = mk error (list ('difference,

'is,
'not,
'defined,
'on,

v1 ,

'and,

v2 ,

'because,
'they,
'are,
'neither,
'mappings,
'nor,
'sets))

Definition: domain arg error

= mk error ('(domain is defined only on mappings))

Definition: duplicate field names error (d)

= mk error (list (d, 'has, 'duplicate, 'field, 'names))

Definition: duplicate param names error (n)

= mk error (list ('duplicate, 'formal, 'parameter, 'names, n))

Definition: each id type error (e, c) = mk error (list ('the,

'bound,
'identifier,
'type,
'in,

e,

'of,
'scope,

c,

'is,
'not,
'a,
'bounded,
'index,
'type))

Definition: empty seq error (fn, s) = mk error (list (fn, 'of, 'an, 'empty, 'sequence, s))

Definition: empty type error (td) = mk error (list ('type, td, 'is, 'empty))

Definition: entry not true error (fn, sn) = mk error (list ('the,

'entry,
'spec,
'is,
'not,
'true,
'for,
'function,

fn,

'in,

'scope,

sn))

Definition: field name reserved error (fds) = mk error (list ('reserved,

'identifier,
'cannot,
'be,
'used,
'as,
'a,
'record,
'field,
'name,
'in,

fds))

Definition: first arg error

= mk error ('(first is defined only on sequences))

Definition: function access error (fp) = mk error (list ('function,

'formal,
'parameter,
'cannot,
'be,
'var,

fp))

Definition: if test not boolean error (e, sn) = mk error (list ('the,

'if,
'test,
'of,
'expression,

e,

'in,
'scope,

sn,

'is,
'not,

'a,
'boolean,
'valued,
'expression))

Definition: in arg error (v) = mk error (list ('in,

'is,
'not,
'defined,
'on,

v,

'because,
'it,
'is,
'neither,
'a,
'sequence,
'nor,
'a,
'set))

Definition: indeterminate fn result error (fn, sn) = mk error (list ('function,

fn,

'of,
'scope,

sn,

'returned,
'an,
'indeterminate,
'value))

Definition: intersect args error (v1 , v2 ) = mk error (list ('intersect,

'is,
'not,
'defined,
'on,

v1 ,

'and,

v2 ,

                'because,
                'they,
                'are,
                'neither,
                'mappings,
                'nor,
                'sets))

Definition: last arg error

= mk error ('(last is defined only on sequences))

Definition: lower pred error (td) = mk error (list ('pred, 'of, 'lower, 'of, 'type, td))

Definition: lt colon args error

= mk error ('(can lt colon only to sequences))

Definition: many post conditions error (u, c) = mk error (list (u,

                'has,
                'more,
                'than,
                'one,
                'exit,
                'specification,
                'for,
                'condition,

c))

Definition: many scope error (sn)

= mk error decl (append ('(there are several scopes named),

list (sn)))

Definition: many unit error (i, sn) = mk error decl (cons ('scope,

cons (sn,

                         append ('(has several units named),

list (i)))))

Definition: mapping merge error (v1 , v2 ) = mk error (list ('mappings,

v1 ,

'and,

v2 ,

'have,
'elements,
'with,
'the,
'same,
'selector,
'and,
'different,
'component,
'values))

Definition: mapping selector type error (sd) = mk error (list ('mapping,

'selector,
'type,

sd,

'is,
'not,
'an,
'equality,
'type))

Definition: max arg error

= mk error ('(max is defined only on simple types))

Definition: min arg error

= mk error ('(min is defined only on simple types))

Definition: n too small = mk error (list ('n, 'is, 'too, 'small))

Definition: name already in use error (n)

= mk error (list ('the, 'name, n, 'is, 'already, 'in, 'use))

Definition: negative exponent error = mk error ('(negative exponent))

Definition: no function defn error (fn, sn)

= mk error (list (fn, 'in, 'scope, sn, 'has, 'no, 'definition))

Definition: no scope error (sn) = mk error decl (append ('(there is no scope), list (sn)))

Definition: no such component error (s, i) = mk error (list (s, 'has, 'no, 'component, i))

Definition: no such field error (r, n) = mk error (list (r, 'has, 'no, 'field, n))

Definition: no unit error (i, sn) = mk error decl (list ('unit, i, 'is, 'not, 'in, 'scope, sn))

Definition: non simple subrange type error (td)

= mk error (list ('subrange, 'of, 'non-simple, 'type, td))

Definition: nonfirst arg error

= mk error ('(nonfirst is defined only on sequences))

Definition: nonlast arg error

= mk error ('(nonlast is defined only on sequences))

Definition: not array error (x) = mk error (list (x, 'is, 'not, 'an, 'array))

Definition: not binary op error (op)

= mk error (list (op, 'is, 'not, 'a, 'binary, 'operator))

Definition: not defined on type error (op, td) = mk error (list (op, 'is, 'not, 'defined, 'on, 'type, td))

Definition: not equality type error (td)

= mk error (list (td, 'is, 'not, 'an, 'equality, 'type))

Definition: not expression error (e)

= mk error (list (e, 'is, 'not, 'an, 'expression))

Definition: not function or const error (fn, sn) = mk error (list (fn,

                'of,
                'scope,

sn,

                'is,
                'not,
                'a,
                'function,
                'or,
                'constant))

Definition: not in set error (e, s) = mk error (list (e, 'is, 'not, 'in, 'set, s))

Definition: not in type error (v, td) = mk error (list (v, 'is, 'not, 'in, 'type, td))

Definition: not mapping error (x) = mk error (list (x, 'is, 'not, 'a, 'mapping))

Definition: not mapping type error (td) = mk error (list (td, 'is, 'not, 'a, 'mapping, 'type))

Definition: not range error (r, sn) = mk error (list (r, 'of, 'scope, sn, 'is, 'not, 'a, 'range))

Definition: not record error (x) = mk error (list (x, 'is, 'not, 'a, 'record))

Definition: not record fields error (s, sn) = mk error (list (s,

                'of,
                'scope,

sn,

                'is,
                'not,

                'a,
                'parse,
                'tree,
                'for,
                'record,
                'field,
                'names))

Definition: not selectable error (x)

= mk error (list ('components, 'of, x, 'cannot, 'be, 'selected))

Definition: not sequence error (s) = mk error (list (s, 'is, 'not, 'a, 'sequence))

Definition: not sequence type error (td)

= mk error (list (td, 'is, 'not, 'a, 'sequence, 'type))

Definition: not set type error (td) = mk error (list (td, 'is, 'not, 'a, 'set, 'type))

Definition: not type descriptor error (td)

= mk error (list (td, 'is, 'not, 'a, 'type, 'descriptor))

Definition: not type error (tt, sn) = mk error (list (tt, 'of, 'scope, sn, 'is, 'not, 'a, 'type))

Definition: not unary op error (op)

= mk error (list (op, 'is, 'not, 'a, 'unary, 'operator))

Definition: null undefined error (td)

= mk error (list ('null, 'is, 'not, 'defined, 'on, 'type, td))

Definition: number error (d, b) = mk error (list (d, 'is, 'not, 'a, 'number, 'in, 'base, b))

Definition: omit args error (v) = mk error (list ('cannot,

                'omit,

'from,

v,

'because,
'it,
'is,
'not,
'a,
'set))

Definition: opt default value error (d, sn) = mk error (list (d,

'in,
'scope,

sn,

'is,
'not,
'an,
'opt default initial value expression))

Definition: opt size limit error (r, sn) = mk error (list (r,

'of,
'scope,

sn,

'is,
'not,
'an,
'opt size limit restriction))

Definition: ord arg error

= mk error ('(ord is defined only on scalar types))

Definition: param reserved error (n) = mk error (list ('reserved,

'identifier,

n,

'cannot,
'be,
'used,
'as,
'a,

'formal,
'parameter,
'name))

Definition: pending default value error (td, sn) = mk error (list ('cannot,

'compute,
'default,
'value,
'for,
'pending,
'type,

td,

'in,
'scope,

sn))

Definition: pending in type error (td)

= mk error (list ('in type, 'of, 'pending, 'type, td))

Definition: pending type value set error (td) = mk error (list ('cannot,

'compute,
'value,
'set,
'of,
'pending,
'type,

td))

Definition: pred arg error

= mk error ('(pred is defined only on scalar types))

Definition: range arg error

= mk error ('(range is defined only on mappings))

Definition: range limits error (lo, hi) = mk error (list (lo,

'and,

hi,

'are,
'not,
'of,
'the,
'same,
'non rational,
'simple,
'type))

Definition: rational value set error (td) = mk error (list ('cannot,

'compute,
'the,
'value,
'set,
'of,
'rational,
'type,

td))

Definition: scale int arg error (i, tn)

= mk error (list (i, 'cannot, 'be, 'scaled, 'in, 'type, tn))

Definition: scale type arg error (tn) = mk error (list ('scale,

'is,
'not,
'defined,
'on,
'type,

tn,

'because,
'it,
'is,
'not,
'a,
'scalar,
'type))

Definition: scope id error (sn)

= mk error decl (append ('(scope name),

cons (sn,

            '(cannot be used as a unit name))))

Definition: scope reserved error (sn) = mk error decl (list ('reserved,

    'identifier,

sn,

    'cannot,
    'be,
    'used,
    'as,
    'a,
    'scope,
    'name))

Definition: size arg error

= mk error ('(size is defined only on mappings sequences
sets))

Definition: size limit error (d, sn) = mk error (list ('size,

'limit,

d,

'of,
'scope,

sn,

'is,
'not,
'a,
'non-negative,
'integer,
'expression))

Definition: sub args error (v1 , v2 ) = mk error (list ('sub,

'is,
'not,
'defined,
'on,

v1 ,

'and,

v2 ,

'because,
'they,
'are,
'not,
'mappings,
'or,
'sequences,
'or,
'sets))

Definition: succ arg error

= mk error ('(succ is defined only on scalar types))

Definition: type defn cycle error (tn, sn) = mk error (list ('cycle,

'in,
'type,
'definition,
'on,

tn,

'in,
'scope,

sn))

Definition: type error (td, sn) = mk error (list ('error, 'in, 'type, td, 'of, 'scope, sn))

Definition: unbounded sequence value set error = mk error (list ('cannot,

'compute,
'the,
'value,
'set,
'of,
'a,
'sequence,
'without,
'a,
'size,

'limit,
'restriction))

Definition: unbounded type error (td) = mk error (list ('type, td, 'is, 'not, 'bounded))

Definition: unbounded value set error (td) = mk error (list ('cannot,

'compute,
'the,
'value,
'set,
'of,
'unbounded,
'type,

td))

Definition: union arg error (v1 , v2 ) = mk error (list ('union,

'defined,
'only,
'on,
'mappings,
'and,
'sets,

v1 , v2 ))

Definition: unit reserved error (u) = mk error decl (list ('reserved,

    'identifier,

u,

    'cannot,
    'be,
    'used,
    'as,
    'a,
    'unit,
    'name))

Definition: unknown name error (n) = mk error (list ('the, 'name, n, 'is, 'unknown))

Definition: upper succ error (td) = mk error (list ('succ, 'of, 'upper, 'of, 'type, td))

Definition: upper undefined error (td)

= mk error (list ('upper, 'is, 'not, 'defined, 'on, 'type, td))

Definition: zero divide error = mk error ('(divide by zero))

Definition: zero to the zero power error

= mk error ('(zero to the zero power))
; **************************************
;  Semantic functions - tree extraction
; **************************************

Event: Disable rule.

Event: Disable subtree.

Event: Disable subtree body.

Event: Disable subtree i.

Definition: gname (u) = if identifierp (u)

then let n be uc list (lexeme (u)) in if pack (n) = nil then 'nil~ else pack (n) endif endlet

else nil endif

Definition: entry name (e) = if entry valuep (e)

then let n be uc list (lexeme (e)) in if pack (rcdr (n)) = nil then pack (rcons (rcons (rcdr (n), ascii tilde), rcar (n))) else pack (n) endif endlet

else nil endif

Definition: access (a) = if rule (a,

      prodn (tag ('similar formal data parameters, 'd),
            list (tag ('opt access specification, 'a),
                tag ('identifier list, 'is),
                'colon,
                tag ('type specification, 'ft))))
then access (subtree (a, 'opt access specification))

elseif rule (a,

          prodn (tag ('internal data or condition objects,
                   'iv),
                list (tag ('access specification, 'a),
                   tag ('identifier list, 'is),
                   'colon,
                   tag ('type specification, 'ts),
                   tag ('opt internal initial value, 'v),
                   'semi colon)))

then access (subtree (a, 'access specification)) elseif rule (a,

          prodn (tag ('opt access specification, 'a), 'empty))
then 'const

elseif rule (a,

          prodn (tag ('opt access specification, 'a),
                tag ('access specification, 'a2)))

then access (subtree (a, 'access specification)) elseif rule (a, prodn (tag ('access specification, 'a), 'var))

then 'var
elseif rule (a, prodn (tag ('access specification, 'a), 'const))
then 'const

else nil endif

Definition: arg list (e) = if rule (e,

      prodn (tag ('expression, 'e),
            tag ('modified primary value, 'm)))

then arg list (subtree (e, 'modified primary value)) elseif rule (e,

          prodn (tag ('modified primary value, 'm),

                list (tag ('modified primary value, 'm2),
                   tag ('value modifiers, 'vm))))

then arg list (subtree (e, 'value modifiers)) elseif rule (e,

          prodn (tag ('modified primary value, 'm),
                list (tag ('modified primary value, 'm2),
                   tag ('actual condition parameters, 'cp))))

then arg list (subtree (e, 'modified primary value)) elseif rule (e,

          prodn (tag ('value modifiers, 'm),
                tag ('component selectors, 's)))

then arg list (subtree (e, 'component selectors)) elseif rule (e,

          prodn (tag ('component selectors, 's),
                tag ('arg list, 'as)))

then subtree (e, 'arg list) elseif rule (e,

prodn (tag ('arg list, 'as),

                list ('open paren,
                   tag ('value list, 'vs),
                   'close paren))) then e

else nil endif

Definition: arg listp (x) = if rule (x,

      prodn (tag ('value modifiers, 'm),
            tag ('component selectors, 's)))

then arg listp (subtree (x, 'component selectors)) elseif rule (x,

          prodn (tag ('component selectors, 's),

tag ('arg list, 'as))) then t

elseif rule (x,

prodn (tag ('arg list, 'as),

                list ('open paren,
                   tag ('value list, 'vs),
                   'close paren))) then t

else nil endif

Definition: bound boolean expression (e) = if rule (e,

      prodn (tag ('expression, 'e),
            list ('all, tag ('bound expression, 'b))))

then bound boolean expression (subtree (e, 'bound expression)) elseif rule (e,

          prodn (tag ('expression, 'e),
                list ('some, tag ('bound expression, 'b))))

then bound boolean expression (subtree (e, 'bound expression)) elseif rule (e,

          prodn (tag ('bound expression, 'b),
                list (tag ('identifier list, 'q),
                   'colon,
                   tag ('type specification, 's),
                   'comma,
                   tag ('expression, 'e))))

then subtree (e, 'expression) else nil endif

Definition: bound id (e) = if rule (e,

      prodn (tag ('expression, 'e),
            list ('all, tag ('bound expression, 'b))))

then bound id (subtree (e, 'bound expression)) elseif rule (e,

          prodn (tag ('expression, 'e),
                list ('some, tag ('bound expression, 'b))))

then bound id (subtree (e, 'bound expression)) elseif rule (e,

          prodn (tag ('bound expression, 'b),
                list (tag ('identifier list, 'q),
                   'colon,
                   tag ('type specification, 's),
                   'comma,
                   tag ('expression, 'e))))

then bound id (subtree (e, 'identifier list)) elseif rule (e,

          prodn (tag ('identifier list, 'is),
                list (tag ('identifier list, 'is2),
                   'comma,
                   tag ('identifier, 'i))))

then bound id (subtree (e, 'identifier list)) elseif rule (e,

          prodn (tag ('identifier list, 'is),
                tag ('identifier, 'i)))

then bound id (subtree (e, 'identifier)) elseif rule (e,

prodn (tag ('opt each clause, 'e),

list ('each,

tag ('identifier, 'i),
'colon,
tag ('type specification, 'ts),
'comma)))

then bound id (subtree (e, 'identifier)) elseif identifierp (e) then gname (e) else nil endif

Definition: bound id type (e) = if rule (e,

prodn (tag ('expression, 'e),
list ('all, tag ('bound expression, 'b))))

then bound id type (subtree (e, 'bound expression)) elseif rule (e,

prodn (tag ('expression, 'e),
list ('some, tag ('bound expression, 'b))))

then bound id type (subtree (e, 'bound expression)) elseif rule (e,

prodn (tag ('bound expression, 'b),
list (tag ('identifier list, 'q),
'colon,
tag ('type specification, 's),
'comma,
tag ('expression, 'e))))
then subtree (e, 'type specification)

elseif rule (e,

prodn (tag ('opt each clause, 'e),

list ('each,

tag ('identifier, 'i),
'colon,
tag ('type specification, 'ts),
'comma)))
then subtree (e, 'type specification)

else nil endif

Definition: case exit list2 (ls, e, c) = if rule (ls,

prodn (tag ('case exit labels, 'ls),
list (tag ('case exit labels, 'ls2),
'comma,

                tag ('exit label, 'l))))

then append (case exit list2 (subtree (ls, 'case exit labels), e, c),

case exit list2 (subtree (ls, 'exit label), e, c))

elseif rule (ls,

          prodn (tag ('case exit labels, 'ls),
                tag ('exit label, 'l)))

then case exit list2 (subtree (ls, 'exit label), e, c) elseif rule (ls, prodn (tag ('exit label, 'l), tag ('identifier, 'n))) then case exit list2 (subtree (ls, 'identifier), e, c) elseif rule (ls, prodn (tag ('exit label, 'l), 'normal)) then if c = 'normal then list (e)

else nil endif elseif identifierp (ls) then if gname (ls) = c then list (e)

else nil endif else nil endif

Definition: case exit list (u, c) = if rule (u,

      prodn (tag ('procedure declaration, 'd),
            list ('procedure,
                tag ('identifier, 'pn),
                tag ('external data objects, 'a),
                tag ('opt external conditions, 'c),
                'equal,
                tag ('procedure body, 'b))))

then case exit list (subtree (u, 'procedure body), c) elseif rule (u,

          prodn (tag ('function declaration, 'd),
                list ('function,
                   tag ('identifier, 'fn),
                   tag ('opt external data objects, 'a),
                   'colon,
                   tag ('type specification, 'rt),
                   tag ('opt external conditions, 'c),
                   'equal,
                   tag ('procedure body, 'b))))

then case exit list (subtree (u, 'procedure body), c) elseif rule (u, prodn (tag ('procedure body, 'b), 'pending)) then nil elseif rule (u,

          prodn (tag ('procedure body, 'b),
                list ('begin,

tag ('external operational specification,
    'es),
tag ('opt internal environment, 'iv),
tag ('opt keep specification, 'k),
tag ('opt internal statements, 'st),
'end)))

then case exit list (subtree (u,

    'external operational specification),

c)

elseif rule (u,

prodn (tag ('external operational specification,
's),
list (tag ('opt entry specification, 'e),
tag ('opt exit specification, 'x))))

then case exit list (subtree (u, 'opt exit specification), c)

elseif rule (u, prodn (tag ('opt exit specification, 'e), 'empty))

then nil elseif rule (u,

prodn (tag ('opt exit specification, 'e),

list ('exit,

tag ('non validated specification expression,
    'se),
'semi colon)))

then if c = 'normal

then list (subtree (u,

 'non validated specification expression))

else nil endif elseif rule (u,

prodn (tag ('opt exit specification, 'e),

list ('exit,

tag ('conditional exit specification,
    'c),
'semi colon)))

then case exit list (subtree (u,

    'conditional exit specification),

c)

elseif rule (u,

prodn (tag ('conditional exit specification, 'c),

list ('case,

'open paren,
tag ('case exit body, 'e),
'close paren)))

then case exit list (subtree (u, 'case exit body), c) elseif rule (u,

prodn (tag ('case exit body, 'b), tag ('case exit, 'c)))

then case exit list (subtree (u, 'case exit), c) elseif rule (u,

prodn (tag ('case exit body, 'b),
list (tag ('case exit body, 'b2),
'semi colon,
tag ('case exit, 'c))))

then append (case exit list (subtree (u, 'case exit body), c),

case exit list (subtree (u, 'case exit), c))

elseif rule (u,

prodn (tag ('case exit, 'ce),

list ('is,

tag ('case exit labels, 'l),
'colon,
tag ('non validated specification expression,

'e))))

then case exit list2 (subtree (u, 'case exit labels),

subtree (u,

     'non validated specification expression),

c)

else nil endif

Definition: cdr quantified names (e) = if rule (e,

prodn (tag ('expression, 'e),
list ('all, tag ('bound expression, 'b))))

∨ rule (e,

prodn (tag ('expression, 'e),
list ('some, tag ('bound expression, 'b))))

then cdr quantified names (subtree (e, 'bound expression)) elseif rule (e,

prodn (tag ('bound expression, 'b),
list (tag ('identifier list, 'q),
'colon,
tag ('type specification, 's),
'comma,
tag ('expression, 'e))))

then cdr quantified names (subtree (e, 'identifier list)) elseif rule (e,

prodn (tag ('identifier list, 'is),
list (tag ('identifier list, 'is2),
'comma,
tag ('identifier, 'i))))

then mk identifier list (cdr quantified names (subtree (e,

                                              'identifier list)),

subtree (e, 'identifier))

else nil endif

Definition: quantifier (e) = if rule (e,

      prodn (tag ('expression, 'e),
            list ('all, tag ('bound expression, 'b))))
then 'all

elseif rule (e,

          prodn (tag ('expression, 'e),
                list ('some, tag ('bound expression, 'b))))
then 'some

else nil endif

Definition: cdr quantified exp (e) = let qn be cdr quantified names (e)

in if qn = nil then bound boolean expression (e) else mk quantified expression (quantifier (e),

qn,

bound id type (e),

bound boolean expression (e)) endif endlet

Definition: constant value exp (u) = if rule (u,

      prodn (tag ('constant declaration, 'd),
            list ('const,
                tag ('identifier, 'cn),
                'colon,
                tag ('type specification, 'rt),
                'colon equal,
                tag ('constant body, 'b))))

then constant value exp (subtree (u, 'constant body)) elseif rule (u, prodn (tag ('constant body, 'b), 'pending)) then nil elseif rule (u,

          prodn (tag ('constant body, 'b), tag ('expression, 'p)))

then subtree (u, 'expression) else nil endif Definition: scalar const units (n, u, q) = if rule (u,

      prodn (tag ('identifier list, 'is), tag ('identifier, 'i)))

then rcons (nil,

mk scalar const unit (n, gname (subtree (u, 'identifier)), q))

elseif rule (u,

          prodn (tag ('identifier list, 'is),
                list (tag ('identifier list, 'is2),
                   'comma,
                   tag ('identifier, 'i))))

then rcons (scalar const units (n,

                          subtree (u, 'identifier list),

q − 1),

mk scalar const unit (n, gname (subtree (u, 'identifier)), q))

else nil endif

Definition: scalar value list (u) = if rule (u,

      prodn (tag ('type declaration, 'd),

list ('type,

                tag ('identifier, 'tn),
                'equal,
                tag ('type definition, 'd2))))

then scalar value list (subtree (u, 'type definition)) elseif rule (u,

          prodn (tag ('type definition, 'd),
                tag ('scalar type, 's)))

then scalar value list (subtree (u, 'scalar type)) elseif rule (u,

          prodn (tag ('scalar type, 's),
                list ('open paren,
                   tag ('identifier list, 'is),
                   'close paren)))

then scalar value list (subtree (u, 'identifier list)) elseif rule (u,

          prodn (tag ('identifier list, 'is),
                tag ('identifier, 'i)))

then rcons (nil, gname (subtree (u, 'identifier))) elseif rule (u,

          prodn (tag ('identifier list, 'is),
                list (tag ('identifier list, 'is2),
                   'comma,

                   tag ('identifier, 'i))))

then rcons (scalar value list (subtree (u, 'identifier list)),

gname (subtree (u, 'identifier)))

else nil endif

Definition: derived units (n, u) = if rule (u,

      prodn (tag ('type definition, 'd), tag ('scalar type, 's)))

then derived units (n, subtree (u, 'scalar type)) elseif rule (u,

          prodn (tag ('scalar type, 's),
                list ('open paren,
                   tag ('identifier list, 'is),
                   'close paren)))

then scalar const units (n,

                     subtree (u, 'identifier list),

length (scalar value list (u)) − 1)

else nil endif

Definition: dparam name (d) = if rule (d,

      prodn (tag ('similar formal data parameters, 'd),
            list (tag ('opt access specification, 'a),
                tag ('identifier list, 'is),
                'colon,
                tag ('type specification, 'ft))))

then dparam name (subtree (d, 'identifier list)) elseif rule (d,

          prodn (tag ('identifier list, 'is),
                tag ('identifier, 'i)))

then dparam name (subtree (d, 'identifier)) elseif identifierp (d) then gname (d) else nil endif

Definition: dparam name list (fs) = if fs ≃ nil then nil

else cons (dparam name (car (fs)), dparam name list (cdr (fs))) endif

Definition: each clausep (e) = if rule (e,

      prodn (tag ('opt each clause, 'e),

list ('each,

                tag ('identifier, 'i),
                'colon,
                tag ('type specification, 'ts),

'comma))) then t

elseif rule (e, prodn (tag ('opt each clause, 'e), 'empty)) then f else f endif

Definition: expression from spec (e) = if rule (e,

      prodn (tag ('specification expression, 'se),
            tag ('validated specification expression,
                'se2)))

∨ rule (e,

          prodn (tag ('specification expression, 'se),
                list ('open paren,
                   tag ('validated specification expression,
                       'se2),
                   'close paren)))

then expression from spec (subtree (e,

                               'validated specification expression))

elseif rule (e,

          prodn (tag ('validated specification expression,
                   'se),
                list (tag ('non validated specification expression,
                       'se2),
                   'otherwise,
                   tag ('identifier, 'i))))

then expression from spec (subtree (e,

                               'non validated specification expression))

elseif rule (e,

          prodn (tag ('specification expression, 'se),
                tag ('non validated specification expression,
                   'se2)))

then expression from spec (subtree (e,

                               'non validated specification expression))

elseif rule (e,

          prodn (tag ('non validated specification expression,
                   'se),
                list ('open paren,
                   tag ('proof directive, 'd),
                   tag ('expression, 'e),
                   'close paren)))

∨ rule (e,

             prodn (tag ('non validated specification expression,
                       'se),
                   list (tag ('proof directive, 'd),
                       tag ('expression, 'e))))

∨ rule (e,

             prodn (tag ('non validated specification expression,
                       'se),
                   tag ('expression, 'e)))

then subtree (e, 'expression) else nil endif

Definition: object namep (m) = if rule (m,

      prodn (tag ('expression, 'e),
            tag ('modified primary value, 'm)))

then object namep (subtree (m, 'modified primary value)) elseif rule (m,

          prodn (tag ('modified primary value, 'm),
                tag ('primary value, 'p)))

then object namep (subtree (m, 'primary value)) elseif rule (m,

          prodn (tag ('primary value, 'p), tag ('identifier, 'i)))

then t else f endif

Definition: fn call formp (m) = if rule (m,

      prodn (tag ('expression, 'e),
            tag ('modified primary value, 'm)))

then fn call formp (subtree (m, 'modified primary value)) elseif rule (m,

          prodn (tag ('modified primary value, 'm),

tag ('primary value, 'p))) then object namep (m)

elseif rule (m,

          prodn (tag ('modified primary value, 'm),
                list (tag ('modified primary value, 'm2),
                   tag ('value modifiers, 'vm))))

then object namep (subtree (m, 'modified primary value))

∧ arg listp (subtree (m, 'value modifiers)) elseif rule (m,

          prodn (tag ('modified primary value, 'm),

                list (tag ('modified primary value, 'm2),
                   tag ('actual condition parameters, 'cp))))

then fn call formp (subtree (m, 'modified primary value)) else f endif

Definition: foreign name (u) = if rule (u,

      prodn (tag ('name declaration, 'd),

list ('name,

                tag ('local aliases, 'a),
                'from,
                tag ('identifier, 'fs))))

then foreign name (subtree (u, 'local aliases)) elseif rule (u,

          prodn (tag ('local aliases, 'a),
                tag ('local renaming, 'r)))

then foreign name (subtree (u, 'local renaming)) elseif rule (u,

          prodn (tag ('local aliases, 'a),
                list (tag ('local aliases, 'a2),
                   'comma,
                   tag ('local renaming, 'r))))

then foreign name (subtree (u, 'local renaming)) elseif rule (u,

          prodn (tag ('local renaming, 'r),
                tag ('identifier, 'fn)))

then foreign name (subtree (u, 'identifier)) elseif rule (u,

          prodn (tag ('local renaming, 'r),
                list (tag ('identifier, 'ln),
                   'equal,
                   tag ('identifier, 'fn))))

then foreign name (subtree i (u, 'identifier, 2)) elseif identifierp (u) then gname (u) else nil endif

Definition: foreign scope name (u) = if rule (u,

      prodn (tag ('name declaration, 'd),

list ('name,

                tag ('local aliases, 'a),
                'from,

                tag ('identifier, 'fs))))

then foreign scope name (subtree (u, 'identifier)) elseif identifierp (u) then gname (u) else nil endif

Definition: full dargs (a, p, ft) = if rule (p,

      prodn (tag ('identifier list, 'is), tag ('identifier, 'i)))

then rcons (nil,

mk single formal data parameter (a, subtree (p, 'identifier), ft))

elseif rule (p,

          prodn (tag ('identifier list, 'is),
                list (tag ('identifier list, 'is2),
                   'comma,
                   tag ('identifier, 'i))))

then rcons (full dargs (a, subtree (p, 'identifier list), ft),

mk single formal data parameter (a, subtree (p, 'identifier), ft))

else nil endif

Definition: formal dargs (d) = if rule (d,

      prodn (tag ('procedure declaration, 'd),
            list ('procedure,
                tag ('identifier, 'pn),
                tag ('external data objects, 'a),
                tag ('opt external conditions, 'c),
                'equal,
                tag ('procedure body, 'b))))

then formal dargs (subtree (d, 'external data objects)) elseif rule (d,

          prodn (tag ('function declaration, 'd),
                list ('function,
                   tag ('identifier, 'fn),
                   tag ('opt external data objects, 'a),
                   'colon,
                   tag ('type specification, 'rt),
                   tag ('opt external conditions, 'c),
                   'equal,

                   tag ('procedure body, 'b))))

then formal dargs (subtree (d, 'opt external data objects)) elseif rule (d,

          prodn (tag ('opt external data objects, 'd),

'empty)) then nil

elseif rule (d,

          prodn (tag ('opt external data objects, 'd),
                tag ('external data objects, 'd2)))

then formal dargs (subtree (d, 'external data objects)) elseif rule (d,

          prodn (tag ('external data objects, 'd),
                list ('open paren,
                   tag ('external data objects list, 'd2),
                   'close paren)))

then formal dargs (subtree (d, 'external data objects list)) elseif rule (d,

          prodn (tag ('external data objects list, 'd),
                tag ('similar formal data parameters, 'd2)))
then formal dargs (subtree (d, 'similar formal data parameters))

elseif rule (d,

          prodn (tag ('external data objects list, 'd),
                list (tag ('external data objects list, 'd2),
                   'semi colon,
                   tag ('similar formal data parameters,

'd3))))

then append (formal dargs (subtree (d,

                               'external data objects list)),

formal dargs (subtree (d,

                               'similar formal data parameters)))

elseif rule (d,

          prodn (tag ('similar formal data parameters, 'd),
                list (tag ('opt access specification, 'a),
                   tag ('identifier list, 'is),
                   'colon,
                   tag ('type specification, 'ft))))

then full dargs (access (subtree (d, 'opt access specification)),

              subtree (d, 'identifier list),
              subtree (d, 'type specification))

elseif rule (d,

          prodn (tag ('constant declaration, 'd),
                list ('const,
                   tag ('identifier, 'cn),
                   'colon,
                   tag ('type specification, 'rt),

                   'colon equal,

tag ('constant body, 'b)))) then nil

else nil endif

Definition: formal type (d) = if rule (d,

      prodn (tag ('similar formal data parameters, 'd),
            list (tag ('opt access specification, 'a),
                tag ('identifier list, 'is),
                'colon,
                tag ('type specification, 'ft))))
then subtree (d, 'type specification)

else nil endif

Definition: ibase (b) = if rule (b, prodn (tag ('base, 'b), 'binary)) then 2

elseif rule (b, prodn (tag ('base, 'b), 'octal)) then 8 elseif rule (b, prodn (tag ('base, 'b), 'decimal)) then 10 elseif rule (b, prodn (tag ('base, 'b), 'hex)) then 16 else nil endif

Definition: if else exp (e) = if rule (e,

      prodn (tag ('if expression, 'i),

list ('if,

                tag ('expression, 'b),
                'then,
                tag ('expression, 'p),
                tag ('if expression else part, 'e))))

then if else exp (subtree (e, 'if expression else part)) elseif rule (e,

          prodn (tag ('if expression else part, 'e),
                list ('else, tag ('expression, 'p), 'fi)))

then subtree (e, 'expression) elseif rule (e,

          prodn (tag ('if expression else part, 'e),

list ('elif,

                   tag ('expression, 'b),
                   'then,
                   tag ('expression, 'p),
                   tag ('if expression else part, 'e2))))
then mk tree ('if expression,

cons (mk reserved word ('if), cdr (subtrees (e))))

else nil endif

Definition: kind (u) = if rule (u,

prodn (tag ('unit declaration, 'd),
tag ('type declaration, 'd2)))

then kind (subtree (u, 'type declaration)) elseif rule (u,

prodn (tag ('type declaration, 'd),

list ('type,

tag ('identifier, 'tn),
'equal,
tag ('type definition, 'd2)))) then 'type

elseif rule (u,

prodn (tag ('unit declaration, 'd),
tag ('procedure declaration, 'd2)))
then kind (subtree (u, 'procedure declaration))

elseif rule (u,

prodn (tag ('procedure declaration, 'd),
list ('procedure,
tag ('identifier, 'pn),
tag ('external data objects, 'a),
tag ('opt external conditions, 'c),
'equal,
tag ('procedure body, 'b))))
then 'procedure

elseif rule (u,

prodn (tag ('unit declaration, 'd),
tag ('function declaration, 'd2)))

then kind (subtree (u, 'function declaration)) elseif rule (u,

prodn (tag ('function declaration, 'd),
list ('function,
tag ('identifier, 'fn),
tag ('opt external data objects, 'a),
'colon,
tag ('type specification, 'rt),
tag ('opt external conditions, 'c),
'equal,
tag ('procedure body, 'b))))
then 'function

elseif rule (u,

prodn (tag ('unit declaration, 'd),
tag ('constant declaration, 'd2)))

then kind (subtree (u, 'constant declaration)) elseif rule (u,

prodn (tag ('constant declaration, 'd),
list ('const,
tag ('identifier, 'cn),
'colon,
tag ('type specification, 'rt),
'colon equal,
tag ('constant body, 'b)))) then 'constant

elseif rule (u,

prodn (tag ('unit declaration, 'd),
tag ('lemma declaration, 'd2)))

then kind (subtree (u, 'lemma declaration)) elseif rule (u,

prodn (tag ('lemma declaration, 'd),
list ('lemma,
tag ('identifier, 'ln),
tag ('opt external data objects, 'a),
'equal,
tag ('non validated specification expression,
    'b)))) then 'lemma

elseif rule (u,

prodn (tag ('name declaration, 'd),

list ('name,

tag ('local aliases, 'a),
'from,
tag ('identifier, 'fs)))) then 'name

elseif errorp (u) then 'error else nil endif

Definition: unit name (u) = if rule (u,

prodn (tag ('type declaration, 'd),

list ('type,

tag ('identifier, 'tn),
'equal,
tag ('type definition, 'd2))))

then unit name (subtree (u, 'identifier)) elseif rule (u,

prodn (tag ('procedure declaration, 'd),
list ('procedure,

tag ('identifier, 'pn),
tag ('external data objects, 'a),
tag ('opt external conditions, 'c),
'equal,
tag ('procedure body, 'b))))

then unit name (subtree (u, 'identifier)) elseif rule (u,

prodn (tag ('function declaration, 'd),
list ('function,
tag ('identifier, 'fn),
tag ('opt external data objects, 'a),
'colon,
tag ('type specification, 'rt),
tag ('opt external conditions, 'c),
'equal,
tag ('procedure body, 'b))))

then unit name (subtree (u, 'identifier)) elseif rule (u,

prodn (tag ('constant declaration, 'd),
list ('const,
tag ('identifier, 'cn),
'colon,
tag ('type specification, 'rt),
'colon equal,
tag ('constant body, 'b))))

then unit name (subtree (u, 'identifier)) elseif rule (u,

prodn (tag ('lemma declaration, 'd),
list ('lemma,
tag ('identifier, 'ln),
tag ('opt external data objects, 'a),
'equal,
tag ('non validated specification expression,

'b))))

then unit name (subtree (u, 'identifier)) elseif identifierp (u) then gname (u) else nil endif

Definition: local name (u) = if rule (u,

prodn (tag ('unit declaration, 'd),
tag ('type declaration, 'd2)))

then unit name (subtree (u, 'type declaration)) elseif rule (u,

          prodn (tag ('unit declaration, 'd),
                tag ('procedure declaration, 'd2)))

then unit name (subtree (u, 'procedure declaration)) elseif rule (u,

          prodn (tag ('unit declaration, 'd),
                tag ('function declaration, 'd2)))

then unit name (subtree (u, 'function declaration)) elseif rule (u,

          prodn (tag ('unit declaration, 'd),
                tag ('constant declaration, 'd2)))

then unit name (subtree (u, 'constant declaration)) elseif rule (u,

          prodn (tag ('unit declaration, 'd),
                tag ('lemma declaration, 'd2)))

then unit name (subtree (u, 'lemma declaration)) elseif rule (u,

          prodn (tag ('name declaration, 'd),

list ('name,

                   tag ('local aliases, 'a),
                   'from,
                   tag ('identifier, 'fs))))

then local name (subtree (u, 'local aliases)) elseif rule (u,

          prodn (tag ('local aliases, 'a),
                tag ('local renaming, 'r)))

then local name (subtree (u, 'local renaming)) elseif rule (u,

          prodn (tag ('local aliases, 'a),
                list (tag ('local aliases, 'a2),
                   'comma,
                   tag ('local renaming, 'r))))

then local name (subtree (u, 'local renaming)) elseif rule (u,

          prodn (tag ('local renaming, 'r),
                tag ('identifier, 'fn)))

then local name (subtree (u, 'identifier)) elseif rule (u,

          prodn (tag ('local renaming, 'r),
                list (tag ('identifier, 'ln),
                   'equal,
                   tag ('identifier, 'fn))))

then local name (subtree i (u, 'identifier, 1)) elseif identifierp (u) then gname (u)

else unit name (u) endif

Definition: named unit (u, s) = mk named unit (u, s)

Definition: named unit list (u, fs) = if rule (u,

      prodn (tag ('local aliases, 'a),
            tag ('local renaming, 'r)))

then rcons (nil, named unit (subtree (u, 'local renaming), fs)) elseif rule (u,

          prodn (tag ('local aliases, 'a),
                list (tag ('local aliases, 'a2),
                   'comma,
                   tag ('local renaming, 'r))))

then rcons (named unit list (subtree (u, 'local aliases), fs),

named unit (subtree (u, 'local renaming), fs))

else nil endif

Definition: object name (e) = if rule (e,

      prodn (tag ('expression, 'e),
            tag ('modified primary value, 'm)))

then object name (subtree (e, 'modified primary value)) elseif rule (e,

          prodn (tag ('modified primary value, 'm),
                tag ('primary value, 'p)))

then object name (subtree (e, 'primary value)) elseif rule (e,

          prodn (tag ('modified primary value, 'm),
                list (tag ('modified primary value, 'm2),
                   tag ('value modifiers, 'vm))))

then object name (subtree (e, 'modified primary value)) elseif rule (e,

          prodn (tag ('modified primary value, 'm),
                list (tag ('modified primary value, 'm2),
                   tag ('actual condition parameters, 'cp))))

then object name (subtree (e, 'modified primary value)) elseif rule (e,

          prodn (tag ('primary value, 'p), tag ('identifier, 'i)))

then object name (subtree (e, 'identifier)) elseif identifierp (e) then gname (e) else nil endif Definition: pending type defnp (d) = if rule (d,

      prodn (tag ('type declaration, 'd),

list ('type,

                tag ('identifier, 'tn),
                'equal,
                tag ('type definition, 'd2))))

then pending type defnp (subtree (d, 'type definition)) elseif rule (d, prodn (tag ('type definition, 'd), 'pending)) then t else f endif

Definition: postc (u, c) = let e be case exit list (u, c)

in if length (e) = 0 then mk true expression elseif length (e) = 1 then expression from spec (car (e)) else many post conditions error (u, c) endif endlet

Definition: prec (u) = if rule (u,

      prodn (tag ('procedure declaration, 'd),
            list ('procedure,
                tag ('identifier, 'pn),
                tag ('external data objects, 'a),
                tag ('opt external conditions, 'c),
                'equal,
                tag ('procedure body, 'b))))

then prec (subtree (u, 'procedure body)) elseif rule (u,

          prodn (tag ('function declaration, 'd),
                list ('function,
                   tag ('identifier, 'fn),
                   tag ('opt external data objects, 'a),
                   'colon,
                   tag ('type specification, 'rt),
                   tag ('opt external conditions, 'c),
                   'equal,
                   tag ('procedure body, 'b))))

then prec (subtree (u, 'procedure body)) elseif rule (u,

prodn (tag ('constant declaration, 'd),
list ('const,
tag ('identifier, 'cn),
'colon,
tag ('type specification, 'rt),
'colon equal,
tag ('constant body, 'b))))

then mk true expression elseif rule (u, prodn (tag ('procedure body, 'b), 'pending)) then mk true expression elseif rule (u,

prodn (tag ('procedure body, 'b),
list ('begin,
tag ('external operational specification,
    'es),
tag ('opt internal environment, 'iv),
tag ('opt keep specification, 'k),
tag ('opt internal statements, 'st),
'end)))
then prec (subtree (u, 'external operational specification))

elseif rule (u,

prodn (tag ('external operational specification,
's),
list (tag ('opt entry specification, 'e),
tag ('opt exit specification, 'x))))
then prec (subtree (u, 'opt entry specification))

elseif rule (u,

prodn (tag ('opt entry specification, 'e), 'empty))

then mk true expression elseif rule (u,

prodn (tag ('opt entry specification, 'e),
list ('entry,
tag ('non validated specification expression,
    'se),
'semi colon)))

then prec (subtree (u,

'non validated specification expression))

elseif rule (u,

prodn (tag ('non validated specification expression,
'se),
list ('open paren,
tag ('proof directive, 'd),
tag ('expression, 'e),
'close paren)))

∨ rule (u,

             prodn (tag ('non validated specification expression,
                       'se),
                   list (tag ('proof directive, 'd),
                       tag ('expression, 'e))))

∨ rule (u,

             prodn (tag ('non validated specification expression,
                       'se),
                   tag ('expression, 'e)))

then subtree (u, 'expression) else nil endif

Definition: record field names (d) = if rule (d,

      prodn (tag ('record type, 'r),
            list ('record,
                'open paren,
                tag ('fields, 'f),
                'close paren)))

then record field names (subtree (d, 'fields)) elseif rule (d,

prodn (tag ('fields, 'f),

list (tag ('fields, 'f2),

                   'semi colon,
                   tag ('similar fields, 's))))

then append (record field names (subtree (d, 'fields)),

record field names (subtree (d, 'similar fields)))

elseif rule (d, prodn (tag ('fields, 'f), tag ('similar fields, 's))) then record field names (subtree (d, 'similar fields)) elseif rule (d,

          prodn (tag ('similar fields, 's),
                list (tag ('identifier list, 'is),
                   'colon,
                   tag ('type specification, 'ft))))

then record field names (subtree (d, 'identifier list)) elseif rule (d,

          prodn (tag ('identifier list, 'is),
                list (tag ('identifier list, 'is2),
                   'comma,
                   tag ('identifier, 'i))))

then rcons (record field names (subtree (d, 'identifier list)),

record field names (subtree (d, 'identifier)))

elseif rule (d,

          prodn (tag ('identifier list, 'is),
                tag ('identifier, 'i)))

then rcons (nil, record field names (subtree (d, 'identifier))) elseif identifierp (d) then gname (d) else nil endif

Definition: result type (d) = if rule (d,

      prodn (tag ('function declaration, 'd),
            list ('function,
                tag ('identifier, 'fn),
                tag ('opt external data objects, 'a),
                'colon,
                tag ('type specification, 'rt),
                tag ('opt external conditions, 'c),
                'equal,
                tag ('procedure body, 'b))))
then subtree (d, 'type specification)

elseif rule (d,

          prodn (tag ('constant declaration, 'd),
                list ('const,
                   tag ('identifier, 'cn),
                   'colon,
                   tag ('type specification, 'rt),
                   'colon equal,
                   tag ('constant body, 'b))))
then subtree (d, 'type specification)

else nil endif

Definition: scalar type defnp (d) = if rule (d,

      prodn (tag ('type declaration, 'd),

list ('type,

                tag ('identifier, 'tn),
                'equal,
                tag ('type definition, 'd2))))

then scalar type defnp (subtree (d, 'type definition)) elseif rule (d,

          prodn (tag ('type definition, 'd),
                tag ('scalar type, 's))) then t

else f endif

Definition: scope list (u) = if rule (u,

prodn (tag ('program description, 'pd),
list (tag ('scope declaration list, 'ss),
'opt semi colon)))

then scope list (subtree (u, 'scope declaration list)) elseif rule (u,

prodn (tag ('scope declaration list, 'ss),
tag ('scope declaration, 'sd)))

then rcons (nil, subtree (u, 'scope declaration)) elseif rule (u,

prodn (tag ('scope declaration list, 'ss),
list (tag ('scope declaration list, 'ss2),
   'semi colon,
   tag ('scope declaration, 'sd))))

then rcons (scope list (subtree (u, 'scope declaration list)),

subtree (u, 'scope declaration))

else nil endif

Definition: scope name (u) = if rule (u,

prodn (tag ('scope declaration, 'sd),
list ('scope,
tag ('identifier, 'sn),
'equal,
'begin,
tag ('unit or name declaration list, 'ul),
'opt semi colon,
'end)))

then scope name (subtree (u, 'identifier)) elseif identifierp (u) then gname (u) else nil endif

Definition: unit list (u) = if rule (u,

prodn (tag ('scope declaration, 'sd),
list ('scope,
tag ('identifier, 'sn),
'equal,
'begin,
tag ('unit or name declaration list, 'ul),
'opt semi colon,

                'end)))
then unit list (subtree (u, 'unit or name declaration list))

elseif rule (u,

          prodn (tag ('unit or name declaration list, 'us),
                tag ('unit or name declaration, 'd)))

then unit list (subtree (u, 'unit or name declaration)) elseif rule (u,

          prodn (tag ('unit or name declaration list, 'us),
                list (tag ('unit or name declaration list,
                       'us2),
                   'semi colon,
                   tag ('unit or name declaration, 'd))))

then append (unit list (subtree (u,

                           'unit or name declaration list)),
            unit list (subtree (u, 'unit or name declaration)))

elseif rule (u,

          prodn (tag ('unit or name declaration, 'd),
                tag ('unit declaration, 'd2)))

then unit list (subtree (u, 'unit declaration)) elseif rule (u,

          prodn (tag ('unit declaration, 'd),
                tag ('type declaration, 'd2)))

then unit list (subtree (u, 'type declaration)) elseif rule (u,

          prodn (tag ('type declaration, 'd),

list ('type,

                   tag ('identifier, 'tn),
                   'equal,
                   tag ('type definition, 'd2))))

then cons (u,

derived units (subtree (u, 'identifier),

                      subtree (u, 'type definition)))

elseif rule (u,

          prodn (tag ('unit declaration, 'd),
                tag ('procedure declaration, 'd2)))

then unit list (subtree (u, 'procedure declaration)) elseif rule (u,

          prodn (tag ('procedure declaration, 'd),
                list ('procedure,
                   tag ('identifier, 'pn),
                   tag ('external data objects, 'a),
                   tag ('opt external conditions, 'c),
                   'equal,
                   tag ('procedure body, 'b))))

then cons (u, nil) elseif rule (u,

prodn (tag ('unit declaration, 'd),
tag ('function declaration, 'd2)))

then unit list (subtree (u, 'function declaration)) elseif rule (u,

prodn (tag ('function declaration, 'd),
list ('function,
tag ('identifier, 'fn),
tag ('opt external data objects, 'a),
'colon,
tag ('type specification, 'rt),
tag ('opt external conditions, 'c),
'equal,
tag ('procedure body, 'b))))

then cons (u, nil) elseif rule (u,

prodn (tag ('unit declaration, 'd),
tag ('constant declaration, 'd2)))

then unit list (subtree (u, 'constant declaration)) elseif rule (u,

prodn (tag ('constant declaration, 'd),
list ('const,
tag ('identifier, 'cn),
'colon,
tag ('type specification, 'rt),
'colon equal,
tag ('constant body, 'b))))

then cons (u, nil) elseif rule (u,

prodn (tag ('unit declaration, 'd),
tag ('lemma declaration, 'd2)))

then unit list (subtree (u, 'lemma declaration)) elseif rule (u,

prodn (tag ('lemma declaration, 'd),
list ('lemma,
tag ('identifier, 'ln),
tag ('opt external data objects, 'a),
'equal,
tag ('non validated specification expression,

'b)))) then cons (u, nil)

elseif rule (u,

prodn (tag ('unit or name declaration, 'd),
tag ('name declaration, 'd2)))

then unit list (subtree (u, 'name declaration))

elseif rule (u,

             prodn (tag ('name declaration, 'd),

list ('name,

                       tag ('local aliases, 'a),
                       'from,
                       tag ('identifier, 'fs))))

then named unit list (subtree (u, 'local aliases),

subtree (u, 'identifier))

else nil endif

; **********************
;  Reserved Identifiers
; **********************
; (defn reserved_words () ...)
;   defined above under "Parse Tree Leaves"

Definition: standard ids

= '(activationid boolean character integer rational true
      false allfrom allto content domain empty first full
      infrom infrommerge initial last lower max messages
      min nonfirst nonlast null ord outto outtomerge pred
      range scale size succ timedallfrom timedallto
      timedinfrom timedinfrommerge timedmerge timedorder
      timedoutto timedouttomerge upper routineerror
      spaceerror)

Definition: reserved idp (n) = let i be if litatom (n) then pack (uc list (unpack (n)))

else pack (uc list (n)) endif

in

(i ∈ reserved words) ∨ (i ∈ standard ids) endlet

Definition: some reserved idp (s) = if s ≃ nil then f

else reserved idp (car (s)) ∨ some reserved idp (cdr (s)) endif

;; *****************
;;  Unit references
;; *****************

Definition: local unit names (ul) = if ul ≃ nil then nil

else cons (local name (car (ul)), local unit names (cdr (ul))) endif

Definition: local names (sd) = cons (scope name (sd), local unit names (unit list (sd)))

Definition: all scopes (n, s) = if s ≃ nil then nil

elseif scope name (car (s)) = n

then cons (car (s), all scopes (n, cdr (s)))

else all scopes (n, cdr (s)) endif

Definition: all units (n, u) = if u ≃ nil then nil

elseif local name (car (u)) = n then cons (car (u), all units (n, cdr (u))) else all units (n, cdr (u)) endif

Event: Disable reserved idp.

Event: Disable unit reserved error.

Event: Disable scope reserved error.

Event: Disable scope id error.

Event: Disable alias id error.

Event: Disable no scope error.

Event: Disable no unit error.

Event: Disable many unit error.

Event: Disable many scope error.

Definition: mref (i, sn, x, m) = if reserved idp (i) then cons (sn, unit reserved error (i))

elseif reserved idp (sn) then cons (sn, scope reserved error (sn)) elseif i = sn then cons (sn, scope id error (sn)) elseif fix (m) = 0 then cons (sn, alias id error (i, sn)) else let slist be all scopes (sn, scope list (x))

in

if length (slist) = 0

then cons (sn, no scope error (sn))

elseif length (slist) = 1

then let ulist be all units (i,

unit list (car (slist)))

in

if length (ulist) = 0

then cons (sn, no unit error (i, sn)) elseif length (ulist) = 1 then let u be car (ulist)

in

if kind (u) = 'name

then mref (foreign name (u), foreign scope name (u), x, m − 1) else cons (sn, u) endif endlet

else cons (sn,

many unit error (i, sn)) endif endlet

else cons (sn, many scope error (sn)) endif endlet endif

Event: Enable reserved idp.

Event: Enable unit reserved error.

Event: Enable scope reserved error.

Event: Enable scope id error.

Event: Enable alias id error.

Event: Enable no scope error.

Event: Enable no unit error.

Event: Enable many unit error.

Event: Enable many scope error.

Definition: ref (i, sn, x) = mref (i, sn, x, 2)

Definition: ref unit (x) = cdr (x)

Definition: ref scope (x) = car (x)

; ****************
;  Marked Objects
; ****************

Event: Add the shell marked, with recognizer function symbol markedp and 2 accessors: mark, with type restriction (none-of) and default value false; object, with type restriction (none-of) and default value zero.

Definition: unmark (o) = if markedp (o) then object (o)

else o endif

; ****************************
;  Pre-Computable Expressions
; ****************************

Event: Introduce the function symbol precomputable f of 3 arguments.

; constraint on precomputable_F:
;   (or (indeterminate (precomputable_F e c x))
;       (equal (precomputable_F e c x)
;              (gF e c (empty_map) n x)))
; for some n.

; ****************************
;  Type Descriptor Primitives
; ****************************

; A type descriptor is a tree with different forms for integers/rationals,
; scalar types, arrays, records, mappings, sequences, and sets.  There are
; also special forms for pending types and errors.
; ========================
;  Primitive Constructors
; ========================
; --------------
;  Simple Types
; --------------

Definition: mk integer desc (tmin, tmax, udv) = mk tree ('integer,

list (mk tree ('tmin, tmin), mk tree ('tmax, tmax), mk tree ('udv, udv)))

Definition: mk rational desc (tmin, tmax, udv)

= mk tree ('rational,

list (mk tree ('tmin, tmin), mk tree ('tmax, tmax), mk tree ('udv, udv)))

Definition: mk scalar desc (tid, sid, crd, tmin, tmax, udv) = mk tree ('scalar,

list (mk tree ('tid, tid), mk tree ('sid, sid), mk tree ('crd, crd), mk tree ('tmin, tmin), mk tree ('tmax, tmax), mk tree ('udv, udv)))

; -------------
;  Array Types
; -------------

Definition: mk array desc (id, cd, udv) = mk tree ('array, list (mk tree ('selector td, id),

               mk tree ('component td, cd),

mk tree ('udv, udv)))

; --------------
;  Record Types
; --------------

Definition: mk record desc (fds, udv) = mk tree ('record,

list (mk tree ('field tds, fds), mk tree ('udv, udv)))

; ---------------
;  Mapping Types
; ---------------

Definition: mk mapping desc (sl, sd, cd, udv) = mk tree ('mapping,

list (mk tree ('max size, sl), mk tree ('selector td, sd),

               mk tree ('component td, cd),

mk tree ('udv, udv)))

; ----------------
;  Sequence Types
; ----------------

Definition: mk sequence desc (sl, cd, udv)

= mk tree ('sequence,

list (mk tree ('max size, sl),

               mk tree ('component td, cd),

mk tree ('udv, udv)))

; -----------
;  Set Types
; -----------

Definition: mk set desc (sl, cd, udv) = mk tree ('set,

list (mk tree ('max size, sl),

               mk tree ('component td, cd),

mk tree ('udv, udv)))

; ---------------
;  Pending Types
; ---------------

Definition: mk pending desc (tid, sid, udv) = mk tree ('pending,

list (mk tree ('tid, tid), mk tree ('sid, sid), mk tree ('udv, udv)))

; -------------
;  Type Errors
; -------------
; The type descriptor constructor for type errors is
;
;     mk_error (<error message>)
;
; It and functions for specific type errors are defined in the section on
; errors, above.

; ======================
;  Primitive Extractors
; ======================

Definition: component td (td) = subtree body (td, 'component td)

Definition: crd (td) = subtree body (td, 'crd)

Definition: field tds (td) = subtree body (td, 'field tds)

Definition: field td (fn, td) = mapped value (field tds (td), fn)

Definition: max size (td) = subtree body (td, 'max size)

Definition: selector td (td) = subtree body (td, 'selector td)

Definition: sid (td) = subtree body (td, 'sid)

Definition: tid (td) = if root (td) ∈ '(integer rational) then root (td)

else subtree body (td, 'tid) endif

Definition: tmax (td) = subtree body (td, 'tmax)

Definition: tmin (td) = subtree body (td, 'tmin)

Definition: type error msg (td) = if errorp (td) then error msg (td)

else nil endif

Definition: udv (td) = if errorp (td) then td

else subtree body (td, 'udv) endif

; =======================
;  Primitive Recognizers
; =======================

Definition: integer descp (td) = (td = mk integer desc (tmin (td), tmax (td), udv (td)))

Definition: rational descp (td) = (td = mk rational desc (tmin (td), tmax (td), udv (td)))

Definition: scalar descp (td) = (td = mk scalar desc (tid (td),

sid (td), crd (td), tmin (td), tmax (td), udv (td)))

Definition: simple descp (td) = (integer descp (td) ∨ rational descp (td) ∨ scalar descp (td))

Definition: array descp (td) = (td = mk array desc (selector td (td), component td (td), udv (td)))

Definition: record descp (td) = (td = mk record desc (field tds (td), udv (td)))

Definition: mapping descp (td) = (td = mk mapping desc (max size (td),

selector td (td), component td (td), udv (td)))

Definition: sequence descp (td) = (td = mk sequence desc (max size (td), component td (td), udv (td)))

Definition: set descp (td) = (td = mk set desc (max size (td), component td (td), udv (td)))

Definition: pending descp (td) = (td = mk pending desc (tid (td), sid (td), udv (td)))

Definition: error descp (td) = errorp (td)

Definition: type descp (td) = (simple descp (td)

∨ array descp (td) ∨ record descp (td) ∨ mapping descp (td) ∨ sequence descp (td) ∨ set descp (td) ∨ pending descp (td) ∨ error descp (td))

; ==========================
;  Setting Descriptor Parts
; ==========================

Definition: set tmax (td, v) = subst tree (mk tree ('tmax, v), subtree (td, 'tmax), td)

Definition: set tmin (td, v) = subst tree (mk tree ('tmin, v), subtree (td, 'tmin), td)

Definition: set udv (td, v) = subst tree (mk tree ('udv, v), subtree (td, 'udv), td)

; ***************************************
;  Descriptors for Standard Simple Types
; ***************************************

Definition: boolean desc = mk scalar desc ('boolean, nil, 2, 0, 1, 0)

Definition: character desc = mk scalar desc ('character, nil, 128, 0, 127, 0)

Definition: integer desc = mk integer desc (nil, nil, 0)

Definition: rational desc = mk rational desc (nil, nil, rational (0, 1))

; ******************
;  Type Recognizers
; ******************

Definition: integer typep (td) = integer descp (td)

Definition: rational typep (td) = rational descp (td)

Definition: scalar typep (td) = scalar descp (td)

Definition: boolean typep (td) = (scalar typep (td) ∧ (tid (td) = 'boolean))

Definition: character typep (td) = (scalar typep (td) ∧ (tid (td) = 'character))

Definition: simple typep (td) = (integer typep (td) ∨ rational typep (td) ∨ scalar typep (td))

Definition: bounded typep (td) = if simple typep (td) then (tmin (td) ≠ nil) ∧ (tmax (td) ≠ nil)

else f endif Definition: equality typep (td) = type descp (td)

Definition: non rational simple typep (td) = (simple typep (td) ∧ (¬ rational typep (td)))

Definition: index typep (td) = non rational simple typep (td)

Definition: bounded index typep (td) = (index typep (td) ∧ bounded typep (td))

; ***************************
;  Functions on Gypsy Values
; ***************************
; Gypsy values are represented as integers, rationals, selector-component
; maps, and lists.   A selector-component map is a list of pairs.  The car of
; each pair is a selector (index, field name).  The cdr is the Gypsy value of
; that component.
;
; Values of boolean, character, integer, and user-defined scalar types are all
; represented as integers.
;
; Values of rational types are represented as rationals.
;
; Values of arrays, records, and mappings are represented as
; selector-component maps from indexes, field names, and selectors,
; respectively, to components.
;
; Values of sequences and sets are represented as lists of components.

Definition: null map = empty map

Definition: null seq = nil

Definition: null set = nil

Definition: field names (v) = keys (v)

Definition: vselectors (v) = keys (v)

Definition: vcomponents (v) = key values (v)

Definition: vdomain (v) = vselectors (v)

Definition: vindexes (v) = vselectors (v)

Definition: vrange (v) = vcomponents (v)

Definition: fselect (m, k) = if in map (m, k) then mapped value (m, k)

else no such component error (m, k) endif

; =================================
;  Lemmas for the Vequal Do-Mutual
; =================================

Theorem: list tree size not zero listp (x) → (tree size (x) ≠ 0)

Theorem: lessp list subtree than subtrees listp (x) → (tree size (list subtree (x, n, i)) < tree size (x))

Theorem: lessp subtree than subtrees listp (subtrees (x)) → (tree size (subtree (x, n)) < tree size (subtrees (x)))

Theorem: lessp subtree body than subtrees listp (subtrees (x)) → (tree size (subtree body (x, n)) < tree size (subtrees (x)))

Theorem: lessp mapping domain tree size 0 tree size (mk set desc (nil, sd, nil)) < tree size (subtrees (mk mapping desc (s, sd, cd, dv)))

Theorem: lessp mapping domain tree size mapping descp (x) → (tree size (mk set desc (nil, subtree body (x, 'selector td), nil))

< tree size (subtrees (x)))

Theorem: listp array desc subtrees array descp (x) → listp (subtrees (x))

Theorem: listp record desc subtrees record descp (x) → listp (subtrees (x))

Theorem: listp mapping desc subtrees mapping descp (x) → listp (subtrees (x))

Theorem: listp sequence desc subtrees sequence descp (x) → listp (subtrees (x))

Theorem: listp set desc subtrees set descp (x) → listp (subtrees (x))

Theorem: treep type desc type descp (x) → treep (x)

Theorem: lessp cdr tree size listp (x) → (tree size (cdr (x)) < tree size (x))

Theorem: lessp cdar tree size listp (x) → (tree size (cdar (x)) < tree size (x))

; ======================
;  The Vequal Do-Mutual
; ======================

Event: Disable mk set desc.

Event: Disable type descp.

Event: Disable array descp.

Event: Disable record descp.

Event: Disable mapping descp.

Event: Disable sequence descp.

Event: Disable set descp.

#|
(do-mutual '(
(defn vmapped_value (m k td)
  ; m is a selector-component map
  ; k is a Gypsy value, the selector
  ; td is the type descriptor for k and keys of m
  ; result is m[k]
  (if (nlistp m)
      (no_such_component_error m k)

(if (vequal (caar m) k td)
    (cdar m)
  (vmapped_value (cdr m) k td)))
( (ord-lessp (cons (cons (add1 (tree_size td))
 (add1 (count m)))
   (count k))) ))
(defn vmapped_value_list (m ks td)
; m is a selector-component-map
; ks is a list of Gypsy values, the selectors
; td is the type descriptor for elements of ks and keys of m
; result is a list of components
(if (nlistp ks)
    nil
  (cons (vmapped_value m (car ks) td)
(vmapped_value_list m (cdr ks) td)))
( (ord-lessp (cons (cons (add1 (tree_size td))
 (add1 (count m)))
   (count ks))) ))
(defn vequal_list (v1 v2 td)
(if (nlistp v1)
    (nlistp v2)
(if (nlistp v2)
    F
  (and (vequal (car v1) (car v2) td)
(vequal_list (cdr v1) (cdr v2) td))))
( (ord-lessp (cons (cons (add1 (tree_size td))
 (add1 (count v1)))
   (count v2))) ))
(defn varray_equal (v1 v2 td)
; entry (and (array_descp td)
;            (truep (dtype td v1))
;            (truep (dtype td v2)))
; Note: Because v1 and v2 are both in type td
;       (and (equal (vindexes v1) (value_set (selector_td td)))
;            (equal (vindexes v2) (value_set (selector_td td))))
(if (array_descp td)
    (vequal_list (vcomponents v1)
 (vmapped_value_list v2 (vindexes v1) (selector_td td))
 (component_td td))
  F)
( (ord-lessp (cons (cons (add1 (tree_size (subtrees td)))

 (add1 (count v1)))
   (count v2))) ))
(defn vfields_equal (v1 v2 tds)
; entry (and (equal (field_names v1) (field_names v2))
;            (subset (field_names tds) (field_names v1)))
(if (nlistp tds)
    T
  (and (vequal (fselect v1 (caar tds))
(fselect v2 (caar tds))
(cdar tds))
(vfields_equal v1 v2 (cdr tds))))
( (ord-lessp (cons (cons (add1 (tree_size tds))
 (add1 (count v1)))
   (count v2))) ))
(defn vrecord_equal (v1 v2 td)
; entry (and (record_descp td)
;            (truep (dtype td v1))
;            (truep (dtype td v2)))
; Note: Because v1 and v2 are both in type td
;       (and (equal (field_names v1) (field_names (field_tds td)))
;            (equal (field_names v2) (field_names (field_tds td))))
(if (record_descp td)
    (vfields_equal v1 v2 (field_tds td))
  F)
( (ord-lessp (cons (cons (add1 (tree_size (subtrees td)))
 (add1 (count v1)))
   (count v2))) ))
(defn vmapping_equal (v1 v2 td)
; entry (and (mapping_descp td)
;            (truep (dtype td v1))
;            (truep (dtype td v2)))
(if (mapping_descp td)
    (and (vequal (vdomain v1) (vdomain v2)
 (mk_set_desc nil (selector_td td) (null_set)))
 (vequal_list (vcomponents v1)
(vmapped_value_list v2 (vdomain v1) (selector_td td))
(component_td td)))
  F)
( (ord-lessp (cons (cons (add1 (tree_size (subtrees td)))
 (add1 (count v1)))
   (count v2))) ))

(defn vsequence_equal (v1 v2 td)
; entry (and (sequence_descp td)
;            (truep (dtype td v1))
;            (truep (dtype td v2)))
(if (sequence_descp td)
    (vequal_list v1 v2 (component_td td))
  F)
( (ord-lessp (cons (cons (add1 (tree_size (subtrees td)))
 (add1 (count v1)))
   (count v2))) ))
(defn vset_equal (v1 v2 td)
; entry (and (set_descp td)
;            (truep (dtype td v1))
;            (truep (dtype td v2)))
(if (set_descp td)
    (and (vsubsetp v1 v2 (component_td td))
 (vsubsetp v2 v1 (component_td td)))
  F)
( (ord-lessp (cons (cons (add1 (tree_size (subtrees td)))
 (add1 (count v1)))
   (count v2))) ))
(defn vequal (v1 v2 td)
; entry (and (type_descp td)
;            (truep (dtype td v1))
;            (truep (dtype td v2)))
(if (type_descp td)
    (case (root td)
(array (varray_equal v1 v2 td))
(record (vrecord_equal v1 v2 td))
(mapping (vmapping_equal v1 v2 td))
(sequence (vsequence_equal v1 v2 td))
(set (vset_equal v1 v2 td))
(rational (requal v1 v2))
(otherwise ; td is a non-rational simple type
(equal v1 v2)))
  F)
( (ord-lessp (cons (cons (add1 (tree_size td))
 (add1 (count v1)))
   (count v2))) ))
(defn vsubsetp (v1 v2 td)

; td is the type descriptor for v1's and v2's components
(if (nlistp v1)
T
(and (vmember (car v1) v2 td)
(vsubsetp (cdr v1) v2 td)))
( (ord-lessp (cons (cons (add1 (tree_size td))
(add1 (count v1)))
(count v2))) ))
(defn vmember (e s td)
; td is the type descriptor for e and s's components
(if (nlistp s)
F
(or (vequal e (car s) td)
(vmember e (cdr s) td)))
( (ord-lessp (cons (cons (add1 (tree_size td))
(add1 (count e)))
(count s))) ))
))
|#

Definition: mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value (mutual-flg,

e, k, ks, m, s, td, tds, v1 , v2 )

= case on mutual-flg:

case = vmember then if s ≃ nil then f

else mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal, t, t, t, t, t, td, t, e, car (s))

∨ mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmember, e, t, t, t, cdr (s), td, t, t,

t) endif

case = vsubsetp then if v1 ≃ nil then t

else mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmember, car (v1 ), t, t, t, v2 , td, t, t, t)

∧ mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vsubsetp, t, t, t, t, t, td, t, cdr (v1 ), v2 ) endif

case = vequal then if type descp (td)

then case on root (td):

case = array then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('varray equal,

t, t, t, t, t, td, t, v1 , v2 )

case = record then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vrecord equal,

t, t, t, t, t, td, t, v1 , v2 )

case = mapping then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmapping equal,

t, t, t, t, t, td, t, v1 , v2 )

case = sequence then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vsequence equal,

t, t, t, t, t, td, t, v1 , v2 )

case = set then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vset equal,

t, t, t, t, t, td, t, v1 , v2 )

case = rational then requal (v1 , v2 ) otherwise v1 = v2 endcase

else f endif case = vset equal then if set descp (td)

then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vsubsetp, t, t, t, t, t, component td (td), t, v1 , v2 )

∧ mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vsubsetp, t, t, t, t, t, component td (td), t, v2 , v1 )

else f endif case = vsequence equal then if sequence descp (td)

then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal list, t, t, t, t, t, component td (td), t, v1 , v2 )

else f endif case = vmapping equal then if mapping descp (td)

then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal, t, t, t, t, t, mk set desc (nil,

selector td (td), null set),

t, vdomain (v1 ), vdomain (v2 ))

∧ mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal list, t, t, t, t, t, component td (td), t, vcomponents (v1 ), mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmapped value list,

t, t, vdomain (v1 ), v2 , t, selector td (td), t, t, t))

else f endif case = vrecord equal then if record descp (td)

then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vfields equal, t, t, t, t, t, t, field tds (td), v1 , v2 )

else f endif case = vfields equal then if tds ≃ nil then t

else mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal, t, t, t, t, t, cdar (tds), t, fselect (v1 ,

caar (tds)), fselect (v2 ,

caar (tds)))

∧ mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vfields equal, t, t, t, t, t, t, cdr (tds), v1 , v2 ) endif

case = varray equal then if array descp (td)

then mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal list, t, t, t, t, t, component td (td), t, vcomponents (v1 ), mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmapped value list,

t, t, vindexes (v1 ), v2 , t, selector td (td), t, t, t))

else f endif case = vequal list then if v1 ≃ nil then v2 ≃ nil

elseif v2 ≃ nil then f else mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal,

t, t, t, t, t, td, t, car (v1 ), car (v2 ))

∧ mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal list, t, t, t, t, t, td, t, cdr (v1 ), cdr (v2 )) endif

case = vmapped value list then if ks ≃ nil then nil

else cons (mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmapped value, t, car (ks), t, m, t, td, t, t, t),

mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmapped value list, t, t, cdr (ks), m, t, td, t, t, t)) endif

otherwise if m ≃ nil then no such component error (m, k)

elseif mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal, t, t, t, t, t, td, t, caar (m), k)

then cdar (m) else mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmapped value,

t, k, t, cdr (m), t, td, t, t,

t) endif endcase

Definition: vmember (e, s, td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmember,

e, t, t, t, s, td, t, t, t)

Definition: vsubsetp (v1 , v2 , td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vsubsetp,

t, t, t, t, t, td, t, v1 , v2 )

Definition: vequal (v1 , v2 , td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal,

t, t, t, t, t, td, t, v1 , v2 )

Definition: vset equal (v1 , v2 , td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vset equal,

t, t, t, t, t, td, t, v1 , v2 )

Definition: vsequence equal (v1 , v2 , td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vsequence equal,

t, t, t, t, t, td, t, v1 , v2 )

Definition: vmapping equal (v1 , v2 , td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmapping equal,

t, t, t, t, t, td, t, v1 , v2 )

Definition: vrecord equal (v1 , v2 , td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vrecord equal,

t, t, t, t, t, td, t, v1 , v2 )

Definition: vfields equal (v1 , v2 , tds) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vfields equal,

t, t, t, t, t, t, tds, v1 , v2 )

Definition: varray equal (v1 , v2 , td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('varray equal,

t, t, t, t, t, td, t, v1 , v2 )

Definition: vequal list (v1 , v2 , td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vequal list,

t, t, t, t, t, td, t, v1 , v2 )

Definition: vmapped value list (m, ks, td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmapped value list,

t, t, ks, m, t, td, t, t, t)

Definition: vmapped value (m, k, td) = mutual-vmember-vsubsetp-vequal-vset equal-vsequence equal-vmapping equal-vrecord equal-vfields equal-varray equal-vequal list-vmapped value list-vmapped value ('vmapped value,

t, k, t, t, td, t, t, t)

Definition: vsize (v) = length (v)

Definition: vseq select (v, k) = if (k ∈ N) ∧ (1 ≤ k) ∧ (k ≤ vsize (v)) then nth (k, v)

else no such component error (v, k) endif

Definition: vsubseq select (v, lo, hi) = if lo > vsize (v) then nil

elseif (1 ≤ lo) ∧ (lo ≤ hi)

then cons (vseq select (v, lo), vsubseq select (v, 1 + lo, hi))

else nil endif

Definition: vselect (v, k, td) = if type descp (td)

then case on root (td): case = array then vmapped value (v, k, selector td (td)) case = record then fselect (v, k) case = mapping then vmapped value (v, k, selector td (td)) case = sequence then vseq select (v, k) otherwise not selectable error (td) endcase

else not type descriptor error (td) endif

Definition: vmap put (m, k, v, td) = if m ≃ nil then cons (map entry (k, v), m)

elseif vequal (caar (m), k, td) then cons (map entry (k, v), cdr (m)) else cons (car (m), vmap put (cdr (m), k, v, td)) endif

Definition: varray put (a, i, v, td) = vmap put (a, i, v, selector td (td))

Definition: vrecord put (r, fn, v) = add to map (r, fn, v)

Definition: vmapping put (m, i, v, td) = vmap put (m, i, v, selector td (td))

Definition: vsequence put (s, i, v) = if s ≃ nil then s

elseif i = 1 then cons (v, cdr (s))

else cons (car (s), vsequence put (cdr (s), i − 1, v)) endif

Definition: vsetp (s, td) = if s ≃ nil then t

else (¬ vmember (car (s), cdr (s), td)) ∧ vsetp (cdr (s), td) endif

Definition: vset (vs, td) = if vs ≃ nil then nil

elseif vmember (car (vs), cdr (vs), td) then vset (cdr (vs), td)

else cons (car (vs), vset (cdr (vs), td)) endif

Definition: vsubmapp (v1 , v2 , td) = if v1 ≃ nil then t

else let c be vselect (v2 , caar (v1 ), td)

in

if errorp (c) then f

else vequal (cdar (v1 ), c, component td (td)) ∧ vsubmapp (cdr (v1 ), v2 , td) endif endlet endif

Definition: vsubseqp (v1 , v2 , td) = if v1 ≃ nil then t

elseif v2 ≃ nil then f

elseif vequal (car (v1 ), car (v2 ), td) then vsubseqp (cdr (v1 ), cdr (v2 ), td) else vsubseqp (v1 , cdr (v2 ), td) endif

Definition: vsubp (v1 , v2 , td) = case on root (td):

case = mapping

then vsubmapp (v1 , v2 , td)

case = sequence

then vsubseqp (v1 , v2 , component td (td))

case = set

then vsubsetp (v1 , v2 , component td (td))

otherwise f endcase Definition: vmap remove (m, k, td) = if m ≃ nil then m

elseif vequal (caar (m), k, selector td (td)) then cdr (m) else cons (car (m), vmap remove (cdr (m), k, td)) endif

Definition: vremove (v1 , v2 , td) = if listp (v2 )

then if vequal (v1 , car (v2 ), td) then vremove (v1 , cdr (v2 ), td) else cons (car (v2 ), vremove (v1 , cdr (v2 ), td)) endif

else v2 endif

Definition: vdifference (v1 , v2 , td) = if v1 ≃ nil then v1

elseif vmember (car (v1 ), v2 , component td (td))

then vdifference (cdr (v1 ), v2 , td)

else cons (car (v1 ), vdifference (cdr (v1 ), v2 , td)) endif

Definition: vdifference maps (v1 , v2 , td) = if v1 ≃ nil then v1

else let c be vselect (v2 , caar (v1 ), td)

in

if errorp (c)

then cons (car (v1 ), vdifference maps (cdr (v1 ), v2 , td)) elseif vequal (cdar (v1 ), c, component td (td)) then vdifference maps (cdr (v1 ), v2 , td) else mapping merge error (v1 , v2 ) endif endlet endif

Definition: vintersect (v1 , v2 , td) = if v1 ≃ nil then v1

elseif vmember (car (v1 ), v2 , component td (td)) then cons (car (v1 ), vintersect (cdr (v1 ), v2 , td)) else vintersect (cdr (v1 ), v2 , td) endif

Definition: vintersect maps (v1 , v2 , td) = if v1 ≃ nil then v1

else let c be vselect (v2 , caar (v1 ), td)

in

if errorp (c) then vintersect maps (cdr (v1 ), v2 , td) elseif vequal (cdar (v1 ), c, component td (td)) then cons (car (v1 ), vintersect maps (cdr (v1 ), v2 , td)) else mapping merge error (v1 , v2 ) endif endlet endif

Definition: vunion (v1 , v2 , td) = if v1 ≃ nil then v2

elseif vmember (car (v1 ), v2 , component td (td))

then vunion (cdr (v1 ), v2 , td)

else cons (car (v1 ), vunion (cdr (v1 ), v2 , td)) endif

Definition: vunion maps (v1 , v2 , td) = if v1 ≃ nil then v2

else let c be vselect (v2 , caar (v1 ), td)

in

if errorp (c)

then cons (car (v1 ), vunion maps (cdr (v1 ), v2 , td)) elseif vequal (cdar (v1 ), c, component td (td)) then vunion maps (cdr (v1 ), v2 , td) else mapping merge error (v1 , v2 ) endif endlet endif

; *********************
;  Value Sets of Types
; *********************
; =====================
;  Value Set Utilities
; =====================

Definition: remove larger (s, n) = if s ≃ nil then s

elseif length (car (s)) > n then remove larger (cdr (s), n) else cons (car (s), remove larger (cdr (s), n)) endif

Definition: list cons (x, y) = if y ≃ nil then nil

else cons (cons (x, car (y)), list cons (x, cdr (y))) endif

Definition: all subsets (vs) = if vs ≃ nil then list (nil)

else append (list cons (car (vs), all subsets (cdr (vs))), all subsets (cdr (vs))) endif Definition: all seqs n (rvs, avs, n) = if n ≃ 0 then list (nil)

elseif rvs ≃ nil then nil

else append (list cons (car (rvs), all seqs n (avs, avs, n − 1)), all seqs n (cdr (rvs), avs, n)) endif

Definition: all seqs le n (vs, n) = if n ≃ 0 then list (nil)

else append (all seqs n (vs, vs, n), all seqs le n (vs, n − 1)) endif

Definition: indexed value set (is, rcs, acs) = if is ≃ nil then list (nil)

elseif rcs ≃ nil then nil

else append (list cons (cons (car (is), car (rcs)),

indexed value set (cdr (is), acs, acs)),

indexed value set (is, cdr (rcs), acs)) endif

Definition: index set value set (iss, cs) = if iss ≃ nil then nil

else append (indexed value set (car (iss), cs, cs), index set value set (cdr (iss), cs)) endif

; =======================
;  Value Set Computation
; =======================

Definition: simple value set (td) = if bounded typep (td)

then if non rational simple typep (td)

then if errorp (tmin (td)) then tmin (td) elseif errorp (tmax (td)) then tmax (td) else number list (tmin (td), tmax (td)) endif

else rational value set error (td) endif else unbounded value set error (td) endif

Definition: array value set (is, cs) = if errorp (is) then is

elseif errorp (cs) then cs

else indexed value set (is, cs, cs) endif Theorem: count cons listp (x) → (count (x) = (1 + (count (car (x)) + count (cdr (x)))))

Theorem: zero count imp not list (count (x) = 0) → (¬ listp (x))

Theorem: listp imp count not zero listp (x) → (count (x) ≠ 0)

Event: Disable count cons.

Event: Disable zero count imp not list.

Theorem: listp cdar imp sub1 count not zero listp (cdar (x)) → ((count (x) − 1) ≠ 0)

Theorem: lessp plus cdr caar cddar (listp (fs) ∧ listp (cdar (fs))) → ((count (cdr (fs)) + count (caar (fs)) + count (cddar (fs)))

< ((count (fs) − 1) − 1))

Definition: field list sets (fs) = if fs ≃ nil then list (nil)

else let fn be caar (fs),

fvs be cdar (fs) in if fvs ≃ nil then nil else append (list cons (cons (fn, car (fvs)),

field list sets (cdr (fs))),

field list sets (cons (cons (fn,

cdr (fvs)), cdr (fs)))) endif endlet endif

Definition: record value set (fs) = if errorp (fs) then fs

else field list sets (fs) endif

Definition: mapping value set (sl, ss, cs) = if errorp (sl) then sl

elseif errorp (ss) then ss elseif errorp (cs) then cs else let r be index set value set (all subsets (ss), cs)

in

if sl = nil then r

else remove larger (r, sl) endif endlet endif

Definition: sequence value set (sl, cs) = if errorp (sl) then sl

elseif errorp (cs) then cs

elseif sl ∈ N then all seqs le n (cs, sl)

else unbounded sequence value set error endif

Definition: set value set (sl, cs) = if errorp (sl) then sl

elseif errorp (cs) then cs

elseif sl ∈ N then remove larger (all subsets (cs), sl)

else all subsets (cs) endif

#|
(do-mutual '( ; the value_set do-mutual
(defn field_value_sets (fds)
  (if (nlistp fds)
      fds
    (let ((fv1 (value_set (cdar fds)))
  (fvs (field_value_sets (cdr fds))))
      (if (errorp fv1)
  fv1
      (if (errorp fvs)
  fvs
(cons (map_entry (caar fds) fv1) fvs)))))
  ( (lessp (tree_size fds)) ))
(defn value_set (td)
  ; entry td is a correct type descriptor
  ; returns an errorp or a list of values
  (if (type_descp td)
      (case (root td)
(array (array_value_set (value_set (selector_td td))
(value_set (component_td td))))
(record (record_value_set (field_value_sets (field_tds td))))
(mapping (mapping_value_set (max_size td)
    (value_set (selector_td td))
    (value_set (component_td td))))

(sequence (sequence_value_set (max_size td)
      (value_set (component_td td))))
(set (set_value_set (max_size td)
    (value_set (component_td td))))
(pending (pending_type_value_set_error td))
(error* td)
(otherwise ; (simple_descp td)
  (simple_value_set td)))
    (not_type_descriptor_error td))
  ( (lessp (tree_size td)) ))
))
|#

Definition: mutual-value set-field value sets (mutual-flg, fds, td) = if mutual-flg = 'value set

then if type descp (td)

then case on root (td): case = array then array value set (mutual-value set-field value sets ('value set,

t,

selector td (td)),

mutual-value set-field value sets ('value set, t, component td (td)))

case = record

then record value set (mutual-value set-field value sets ('field value sets, field tds (td), t))

case = mapping

then mapping value set (max size (td),

mutual-value set-field value sets ('value set, t, selector td (td)),

mutual-value set-field value sets ('value set, t, component td (td)))

case = sequence

then sequence value set (max size (td),

mutual-value set-field value sets ('value set, t, component td (td))) case = set then set value set (max size (td),

mutual-value set-field value sets ('value set, t, component td (td)))

case = pending

then pending type value set error (td)

case = error* then td otherwise simple value set (td) endcase

else not type descriptor error (td) endif elseif fds ≃ nil then fds elseif errorp (mutual-value set-field value sets ('value set,

t,

cdar (fds)))

then mutual-value set-field value sets ('value set, t, cdar (fds)) elseif errorp (mutual-value set-field value sets ('field value sets,

cdr (fds),

t))

then mutual-value set-field value sets ('field value sets, cdr (fds), t)

else cons (map entry (caar (fds),

mutual-value set-field value sets ('value set, t, cdar (fds))),

mutual-value set-field value sets ('field value sets, cdr (fds), t)) endif

Definition: value set (td) = mutual-value set-field value sets ('value set, t, td)

Definition: field value sets (fds) = mutual-value set-field value sets ('field value sets, fds, t)

; See below for marked and typed value sets.

; **************
;  Typed Values
; **************

; --------------------------------------------------------------------------
; A typed value is constructed by calling function
;
;     typed (td,u)
;
; where td is a type descriptor and u is a member of td's value set.
; The value of dtype(td,u) = T iff u is a member of td's value set.
; --------------------------------------------------------------------------

Definition: dtype size (n, v) = if errorp (n) then n

elseif n ∈ N then length (v) ≤ n else t endif

Theorem: count keys (key value mapp (v) ∧ (count (keys (v)) ≮ count (v))) → (count (keys (v)) = count (v))

Theorem: count key values (key value mapp (v) ∧ (count (key values (v)) ≮ count (v))) → (count (key values (v)) = count (v))

#|
(do-mutual '(
(defn dtype_list (td vs)
  (if (nlistp vs)
      (equal vs nil)
    (let ((r (dtype td (car vs))))
      (if (truep r)
  (dtype_list td (cdr vs))
r)))
  ( (ord-lessp (cons (add1 (count vs))
     (tree_size td))) ))
(defn dtype_fields (fds fvs)
  (if (nlistp fvs)
      (equal fvs nil)
    (let ((r (dtype (mapped_value fds (caar fvs)) (cdar fvs))))
      (if (truep r)
  (dtype_fields fds (cdr fvs))
r)))
  ( (ord-lessp (cons (add1 (count fvs))

(tree_size fds))) ))
(defn dtype (td v)
; entry td is a correct type descriptor
; v is a Gypsy value
; returns T, F, or an errorp
(if (type_descp td)
 (case (root td)
(array (if (key_value_mapp v)
(let ((ivs (value_set (selector_td td)))
(r (dtype_list (selector_td td) (vindexes v))))
(if (truep r)
(if (errorp ivs)
ivs
(if (and (vsetp (vindexes v) (selector_td td))
(vset_equal ivs (vindexes v)
(mk_set_desc nil
(selector_td td)
(null_set))))
  (dtype_list (component_td td) (vcomponents v))
F))
  r))
F))
(record (if (and (key_value_mapp v)
(setp (field_names v))
(set_equal (field_names (field_tds td))
(field_names v)))
(dtype_fields (field_tds td) v)
F))
(mapping (if (key_value_mapp v)
(let ((r (dtype_list (selector_td td) (vdomain v))))
  (if (truep r)
(if (vsetp (vdomain v) (selector_td td))
  (let ((r (dtype_list (component_td td)
(vrange v))))
(if (truep r)
(dtype_size (max_size td) v)
r))
F)
r))
F))
(sequence (let ((r (dtype_list (component_td td) v)))
(if (truep r)
(dtype_size (max_size td) v)

      r)))
(set (if (vsetp v (component_td td))
 (let ((r (dtype_list (component_td td) v)))
   (if (truep r)
       (dtype_size (max_size td) v)
     r))
       F))
(pending (pending_in_type_error td))
(error* td)
(otherwise ; (simple_descp td)
  (if (errorp (tmin td))
      (tmin td)
  (if (errorp (tmax td))
      (tmax td)
  (if (equal (tid td) 'rational)
      (and (rationalp v)
   (if (bounded_typep td)
       (and (rleq (tmin td) v)
    (rleq v (tmax td)))
     T))
    (and (integerp v)
 (if (bounded_typep td)
     (and (ileq (tmin td) v)
  (ileq v (tmax td)))
   T)))))))
    (not_type_descriptor_error td))
  ( (ord-lessp (cons (add1 (count v))
     (tree_size td))) ))
))
|#

Definition: mutual-dtype-dtype fields-dtype list (mutual-flg, fds, fvs, td, v, vs) = case on mutual-flg:

case = dtype

then if type descp (td)

then case on root (td): case = array then if key value mapp (v)

then if truep (mutual-dtype-dtype fields-dtype list ('dtype list, t, t, selector td (td), t, vindexes (v)))

then if errorp (value set (selector td (td)))

then value set (selector td (td)) elseif vsetp (vindexes (v), selector td (td))

∧ vset equal (value set (selector td (td)), vindexes (v), mk set desc (nil,

selector td (td), null set))

then mutual-dtype-dtype fields-dtype list ('dtype list, t, t, component td (td), t, vcomponents (v))

else f endif else mutual-dtype-dtype fields-dtype list ('dtype list,

t, t, selector td (td), t, vindexes (v)) endif

else f endif case = record then if key value mapp (v)

∧ setp (field names (v)) ∧ set equal (field names (field tds (td)),

field names (v))

then mutual-dtype-dtype fields-dtype list ('dtype fields, field tds (td), v, t, t, t)

else f endif case = mapping then if key value mapp (v)

then if truep (mutual-dtype-dtype fields-dtype list ('dtype list, t, t, selector td (td), t,

vdomain (v)))

then if vsetp (vdomain (v), selector td (td))

then if truep (mutual-dtype-dtype fields-dtype list ('dtype list, t, t, component td (td), t, vrange (v)))

then dtype size (max size (td), v) else mutual-dtype-dtype fields-dtype list ('dtype list,

t, t, component td (td), t, vrange (v)) endif

else f endif else mutual-dtype-dtype fields-dtype list ('dtype list,

t, t, selector td (td), t, vdomain (v)) endif

else f endif case = sequence then if truep (mutual-dtype-dtype fields-dtype list ('dtype list,

t, t, component td (td), t, v))

then dtype size (max size (td), v) else mutual-dtype-dtype fields-dtype list ('dtype list,

t, t, component td (td), t,

v) endif

case = set then if vsetp (v, component td (td))

then if truep (mutual-dtype-dtype fields-dtype list ('dtype list, t, t, component td (td), t, then dtype size (max size (td), v) else mutual-dtype-dtype fields-dtype list ('dtype list,

t, t, component td (td), t,

v) endif

else f endif case = pending then pending in type error (td) case = error* then td otherwise if errorp (tmin (td)) then tmin (td)

elseif errorp (tmax (td)) then tmax (td) elseif tid (td) = 'rational then rationalp (v)

∧ if bounded typep (td)

then rleq (tmin (td), v)

∧ rleq (v, tmax (td)) else t endif

else integerp (v)

∧ if bounded typep (td)

then ileq (tmin (td), v)

∧ ileq (v, tmax (td)) else t endif endif endcase

else not type descriptor error (td) endif case = dtype fields then if fvs ≃ nil then fvs = nil

elseif truep (mutual-dtype-dtype fields-dtype list ('dtype, t, t, mapped value (fds,

caar (fvs)),

cdar (fvs), t))

then mutual-dtype-dtype fields-dtype list ('dtype fields, fds, cdr (fvs), t, t, t)

else mutual-dtype-dtype fields-dtype list ('dtype, t, t, mapped value (fds,

caar (fvs)),

cdar (fvs),

t) endif

otherwise if vs ≃ nil then vs = nil

elseif truep (mutual-dtype-dtype fields-dtype list ('dtype, t, t, td, car (vs), t))

then mutual-dtype-dtype fields-dtype list ('dtype list, t, t, td, t, cdr (vs))

else mutual-dtype-dtype fields-dtype list ('dtype, t, t, td, car (vs),

t) endif endcase

Definition: dtype (td, v) = mutual-dtype-dtype fields-dtype list ('dtype, t, t, td, v, t)

Definition: dtype fields (fds, fvs) = mutual-dtype-dtype fields-dtype list ('dtype fields, fds, fvs, t, t, t)

Definition: dtype list (td, vs) = mutual-dtype-dtype fields-dtype list ('dtype list, t, t, td, t, vs)

Event: Add the shell mk typed, with recognizer function symbol typedp and 2 accessors: type part, with type restriction (none-of) and default value false; value part, with type restriction (none-of) and default value zero.

; member of value set of type_part

Definition: typed (td, u) = if truep (dtype (td, u)) then mk typed (td, u)

else mk typed (integer desc, 0) endif

; *********************
;  Marked Typed Values
; *********************
; --------------------------------------------------------------------------
; Whether a typed value is determinate or indeterminate is indicated by
; marking it with nil for determinate typed values and non-nil for
; indeterminate typed values.
; --------------------------------------------------------------------------

Definition: determinate (x) = if markedp (x) then mark (x) = nil

else f endif

Definition: indeterminate (x) = (¬ determinate (x))

Definition: marked typed (td, u) = if truep (dtype (td, u)) then marked (nil, typed (td, u))

else marked (not in type error (u, td), typed (td, u)) endif

Definition: marked typed list (td, us) = if us ≃ nil then us

else cons (marked typed (td, car (us)), marked typed list (td, cdr (us))) endif

; ************************************
;  Extraction of Type and Value Parts
; ************************************

Definition: type (x) = if markedp (x) then type (unmark (x))

elseif typedp (x) then type part (x)

else f endif

Definition: value (x) = if markedp (x) then value (unmark (x))

elseif typedp (x) then value part (x)

else x endif

Definition: values (s) = if s ≃ nil then nil

else cons (value (car (s)), values (cdr (s))) endif

; *************************
;  Marked Typed Value Sets
; *************************

Definition: marked typed value set (td) = let vs be value set (td)

in

if errorp (vs) then vs

else marked typed list (td, vs) endif endlet

; *************************
;  Default Values of Types
; *************************

Definition: mk array default (id, cd) = let is be value set (id),

cv be udv (cd) in if errorp (is) then is elseif errorp (cv) then cv else pair list map (is, ncopies (length (is), cv)) endif endlet

Definition: mk record default (fds) = if fds ≃ nil then nil

else let fv1 be udv (cdar (fds))

in

if errorp (fv1 ) then fv1

else let fvs be mk record default (cdr (fds)) in if errorp (fvs) then fvs else cons (map entry (caar (fds),

fv1 ),

fvs) endif endlet endif endlet endif

Definition: default value (td) = if type descp (td) ∧ (¬ errorp (udv (td))) then typed (td, udv (td))

else typed (integer desc, 0) endif

; ***********
;  Base Type
; ***********
#|
(do-mutual '(
(defn field_base_types (fds)
  (if (nlistp fds)
      fds
    (cons (map_entry (caar fds) (base_type (cdar fds)))
  (field_base_types (cdr fds))))
  ( (lessp (tree_size fds)) ))
(defn base_type (td)
  ; entry td is a correct type descriptor
  (if (type_descp td)
      (case (root td)
(integer (integer_desc))
(rational (rational_desc))
(scalar (mk_scalar_desc (tid td) (sid td) (crd td)
0 (sub1 (crd td)) 0))
        (array (let ((id (selector_td td))
     (cd (base_type (component_td td))))
 (mk_array_desc id cd (mk_array_default id cd))))
(record (let ((fds (field_base_types (field_tds td))))
  (mk_record_desc fds (mk_record_default fds))))
(mapping (mk_mapping_desc nil (base_type (selector_td td))
  (base_type (component_td td))
  (null_map)))
(sequence (mk_sequence_desc nil (base_type (component_td td))
    (null_seq)))
(set (mk_set_desc nil (base_type (component_td td)) (null_set)))
(pending td)
(error* td)

(otherwise (not_type_descriptor_error td)))
(not_type_descriptor_error td))
( (lessp (tree_size td)) ))
))
|#

Definition: mutual-base type-field base types (mutual-flg, fds, td) = if mutual-flg = 'base type

then if type descp (td)

then case on root (td): case = integer then integer desc case = rational then rational desc case = scalar then mk scalar desc (tid (td),

sid (td), crd (td),

                   0,

crd (td) − 1,

                   0)

case = array then mk array desc (selector td (td),

mutual-base type-field base types ('base type, t, component td (td)),

mk array default (selector td (td),

mutual-base type-field base types ('base type, t, component td (td))))

case = record then mk record desc (mutual-base type-field base types ('field base types,

field tds (td), t), mk record default (mutual-base type-field base types ('field base types,

field tds (td), t)))

case = mapping then mk mapping desc (nil,

mutual-base type-field base types ('base type, t,

selector td (td)),

mutual-base type-field base types ('base type, t, component td (td)),

null map)

case = sequence

then mk sequence desc (nil,

mutual-base type-field base types ('base type, t, component td (td)),

null seq)

case = set

then mk set desc (nil,

mutual-base type-field base types ('base type, t, component td (td)),

null set)

case = pending

then td case = error* then td otherwise not type descriptor error (td) endcase

else not type descriptor error (td) endif elseif fds ≃ nil then fds else cons (map entry (caar (fds),

mutual-base type-field base types ('base type, t, cdar (fds))),

mutual-base type-field base types ('field base types, cdr (fds), t)) endif

Definition: base type (td) = mutual-base type-field base types ('base type, t, td)

Definition: field base types (fds) = mutual-base type-field base types ('field base types, fds, t)

; ***************
;  Type Equality
; ***************

Definition: type vequal (v1 , v2 , td) = if errorp (v1 ) ∨ errorp (v2 ) then f

elseif v1 = nil then v2 = nil else vequal (v1 , v2 , td) endif

#|
(do-mutual '(
(defn field_tds_equal (t1 t2)
  (if (nlistp t1)
      T
    (and (type_equal (cdar t1) (mapped_value t2 (caar t1)))
 (field_tds_equal (cdr t1) t2)))
  ( (lessp (tree_size t1)) ))
(defn type_equal (t1 t2)
  (if (and (type_descp t1) (type_descp t2)
   (equal (root t1) (root t2)))
      (case (root t1)
(integer (and (type_vequal (tmin t1) (tmin t2) t1)
      (type_vequal (tmax t1) (tmax t2) t1)))
(rational (and (type_vequal (tmin t1) (tmin t2) t1)
       (type_vequal (tmax t1) (tmax t2) t1)))
(scalar (and (equal (tid t1) (tid t2))
     (equal (sid t1) (sid t2))
     (type_vequal (crd t1) (crd t2) (integer_desc))
     (type_vequal (tmin t1) (tmin t2) t1)
     (type_vequal (tmax t1) (tmax t2) t1)))
(array (and (type_equal (selector_td t1) (selector_td t2))
    (type_equal (component_td t1) (component_td t2))))
(record (and (set_equal (field_names t1) (field_names t2))
     (field_tds_equal (field_tds t1) (field_tds t2))))
(mapping (and (type_vequal (max_size t1) (max_size t2) (integer_desc))
      (type_equal (selector_td t1) (selector_td t2))
      (type_equal (component_td t1) (component_td t2))))
(sequence (and (type_vequal (max_size t1) (max_size t2) (integer_desc))
       (type_equal (component_td t1) (component_td t2))))
(set (and (type_vequal (max_size t1) (max_size t2) (integer_desc))
  (type_equal (component_td t1) (component_td t2))))
(pending (and (equal (tid t1) (tid t2))
      (equal (sid t1) (sid t2))))
(otherwise F))
    F)
  ( (lessp (tree_size t1)) ))

))
|#

Definition: mutual-type equal-field tds equal (mutual-flg, t1 , t2 ) = if mutual-flg = 'type equal

then if type descp (t1 ) ∧ type descp (t2 ) ∧ (root (t1 ) = root (t2 ))

then case on root (t1 ): case = integer then type vequal (tmin (t1 ), tmin (t2 ), t1 )

∧ type vequal (tmax (t1 ), tmax (t2 ), t1 ) case = rational then type vequal (tmin (t1 ), tmin (t2 ), t1 )

∧ type vequal (tmax (t1 ), tmax (t2 ), t1 ) case = scalar then (tid (t1 ) = tid (t2 ))

∧ (sid (t1 ) = sid (t2 )) ∧ type vequal (crd (t1 ), crd (t2 ), integer desc) ∧ type vequal (tmin (t1 ), tmin (t2 ), t1 ) ∧ type vequal (tmax (t1 ), tmax (t2 ), t1 )

case = array then mutual-type equal-field tds equal ('type equal,

selector td (t1 ), selector td (t2 ))

∧ mutual-type equal-field tds equal ('type equal, component td (t1 ), component td (t2 ))

case = record then set equal (field names (t1 ), field names (t2 ))

∧ mutual-type equal-field tds equal ('field tds equal, field tds (t1 ), field tds (t2 ))

case = mapping then type vequal (max size (t1 ), max size (t2 ), integer desc)

∧ mutual-type equal-field tds equal ('type equal, selector td (t1 ), selector td (t2 ))

∧ mutual-type equal-field tds equal ('type equal, component td (t1 ), component td (t2 )) case = sequence then type vequal (max size (t1 ), max size (t2 ), integer desc) ∧ mutual-type equal-field tds equal ('type equal,

component td (t1 ), component td (t2 ))

case = set

then type vequal (max size (t1 ), max size (t2 ), integer desc) ∧ mutual-type equal-field tds equal ('type equal,

component td (t1 ), component td (t2 ))

case = pending

then (tid (t1 ) = tid (t2 )) ∧ (sid (t1 ) = sid (t2 ))

otherwise f endcase else f endif elseif t1 ≃ nil then t else mutual-type equal-field tds equal ('type equal,

cdar (t1 ),

mapped value (t2 , caar (t1 )))

∧ mutual-type equal-field tds equal ('field tds equal, cdr (t1 ), t2 ) endif

Definition: type equal (t1 , t2 ) = mutual-type equal-field tds equal ('type equal, t1 , t2 )

Definition: field tds equal (t1 , t2 ) = mutual-type equal-field tds equal ('field tds equal, t1 , t2 )

; *********
;  In Type
; *********

Definition: in type (td, u) = if error descp (td) then td

elseif error descp (type (u)) then type (u) elseif type equal (td, type (u)) then t elseif base type (td) = base type (type (u)) then dtype (td, value (u)) else f endif

; *****************************************
;  Lemmas for Proving Type_Desc Terminates

; *****************************************

Definition: all type units (ul, sn) = if ul ≃ nil then nil

elseif kind (car (ul)) = 'type

then cons (cons (sn, car (ul)), all type units (cdr (ul), sn)) else all type units (cdr (ul), sn) endif

Definition: all scope types (sl) = if sl ≃ nil then nil

else append (all type units (unit list (car (sl)),

scope name (car (sl))),

all scope types (cdr (sl))) endif

Definition: all gypsy types (x) = all scope types (scope list (x))

Theorem: all type units members ((u ∈ ul) ∧ (kind (u) = 'type)) → (cons (sn, u) ∈ all type units (ul, sn))

Theorem: member append ((e ∈ x) ∨ (e ∈ y)) → (e ∈ append (x, y))

Theorem: all scope types members ((s ∈ sl) ∧ (u ∈ unit list (s)) ∧ (kind (u) = 'type)) → (cons (scope name (s), u) ∈ all scope types (sl))

Theorem: all gypsy type members ((s ∈ scope list (x)) ∧ (u ∈ unit list (s)) ∧ (kind (u) = 'type)) → (cons (scope name (s), u) ∈ all gypsy types (x))

Theorem: rule imp root equal lhs rule (tr, prodn (lhs, rhs)) → (root (tr) = untag (lhs))

Theorem: not root equal lhs imp not rule ((r ≠ nt) ∧ litatom (nt)) → (rule (mk tree (r, s), prodn (tag (nt, l), rhs)) = f)

Theorem: mk error kind kind (mk error (x)) = 'error

Theorem: all scopes car (length (all scopes (sn, sl)) = 1) → ((scope name (car (all scopes (sn, sl))) = sn)

∧ (car (all scopes (sn, sl)) ∈ sl))

Theorem: all units car (length (all units (un, ul)) = 1) → ((local name (car (all units (un, ul))) = un)

∧ (car (all units (un, ul)) ∈ ul))

Theorem: mref result (kind (ref unit (mref (un, sn, x, n))) ≠ 'error) → ((car (all scopes (ref scope (mref (un, sn, x, n)), scope list (x)))

∈ scope list (x))

∧ (scope name (car (all scopes (ref scope (mref (un, sn, x, n)),

scope list (x))))

= ref scope (mref (un, sn, x, n))) ∧ (ref unit (mref (un, sn, x, n))

∈ unit list (car (all scopes (ref scope (mref (un, sn, x, n)), scope list (x))))))

Theorem: refed type (kind (ref unit (ref (un, sn, x))) = 'type) → ((car (all scopes (ref scope (ref (un, sn, x)), scope list (x)))

∈ scope list (x))

∧ (ref unit (ref (un, sn, x))

∈ unit list (car (all scopes (ref scope (ref (un, sn, x)),

scope list (x)))))

∧ (scope name (car (all scopes (ref scope (ref (un, sn, x)),

scope list (x))))

= ref scope (ref (un, sn, x))))

Theorem: type in all types (kind (ref unit (ref (un, sn, x))) = 'type) → (ref (un, sn, x) ∈ all gypsy types (x))

Theorem: set difference remove listp (y) → (set difference (x, y) = remove (car (y), set difference (x, cdr (y))))

Theorem: set difference member ((e ∈ x) ∧ (e ∉ y)) → (e ∈ set difference (x, y))

Definition: available types (ut, x) = set difference (all gypsy types (x), ut)

Theorem: lessp available types ((kind (ref unit (ref (un, sn, x))) = 'type) ∧ (ref (un, sn, x) ∉ ut)) → (length (available types (cons (ref (un, sn, x), ut), x))

< length (available types (ut, x)))

; ******************************
;  Creation of Type Descriptors
; ******************************
; ===========================
;  Descriptors for the Types
; ===========================
; --------------
;  Simple Types
; --------------
; Descriptors for standard types are defined above:
;
;     type name       function
;     ---------     --------------
;     boolean       boolean_desc
;     character     character_desc
;     integer       integer_desc
;     rational      rational_desc

Definition: subrange desc (td, lo, hi) = let rd be set tmin (set tmax (td, hi), lo)

in

if truep (dtype (rd, udv (td))) then rd else set udv (rd, lo) endif endlet

Definition: scalar desc (tn, sn, sc) = mk scalar desc (tn, sn, sc, 0, sc − 1, 0)

; ------------------
;  Structured Types
; ------------------

Definition: array desc (id, cd) = if error descp (id) then id

elseif error descp (cd) then cd

elseif index typep (id)

then mk array desc (id, cd, mk array default (id, cd))

else array index error (id) endif Definition: record desc (fds) = if error descp (fds) then fds

elseif setp (field names (fds))

then if some reserved idp (field names (fds)) then field name reserved error (fds) else mk record desc (fds, mk record default (fds)) endif

else duplicate field names error (fds) endif

Definition: mapping desc (sl, sd, cd) = if error descp (sd) then sd

elseif error descp (cd) then cd

elseif equality typep (sd) then mk mapping desc (sl, sd, cd, null map) else mapping selector type error (sd) endif

Definition: sequence desc (sl, cd) = if error descp (cd) then cd

else mk sequence desc (sl, cd, null seq) endif

Definition: set desc (sl, cd) = if error descp (cd) then cd

else mk set desc (sl, cd, null set) endif

Definition: pending desc (tid, sid) = mk pending desc (tid, sid, pending default value error (tid, sid))

; ==================================================
;  Evaluation of Expressions from Type Declarations
; ==================================================

Definition: default initial value (d, sn, x) = if rule (d,

          prodn (tag ('opt default initial value expression,
                    'v),
                list ('colon equal, tag ('expression, 'e))))

then precomputable f (subtree (d, 'expression), sn, x)

elseif rule (d,

             prodn (tag ('opt default initial value expression,
                       'v),

'empty)) then nil

else opt default value error (d, sn) endif Definition: size limit (r, sn, x) = if rule (r,

          prodn (tag ('opt size limit restriction, 'r),
                list ('open paren,
                   tag ('expression, 'e),
                   'close paren)))

then let sl be precomputable f (subtree (r, 'expression), sn, x) in if determinate (sl) then let ok be in type (integer desc, sl)

in

if errorp (ok) then ok

elseif truep (ok) ∧ ileq (0, value (sl))

then value (sl)

else size limit error (r, sn) endif endlet elseif errorp (mark (sl)) then mark (sl) else mk error (mark (sl)) endif endlet

elseif rule (r,

             prodn (tag ('opt size limit restriction, 'r),

'empty)) then nil

else opt size limit error (r, sn) endif

Definition: range min (r, sn, x) = if rule (r,

prodn (tag ('range, 'r),

                list ('open paren,
                   tag ('range limits, 'r2),
                   'close paren)))

then range min (subtree (r, 'range limits), sn, x)

elseif rule (r,

             prodn (tag ('range limits, 'r),
                   list (tag ('expression, 'lo),
                       'dot dot,
                       tag ('expression, 'hi))))

then precomputable f (subtree i (r, 'expression, 1), sn, x)

else not range error (r, sn) endif

Definition: range max (r, sn, x) = if rule (r,

prodn (tag ('range, 'r),

                list ('open paren,

                   tag ('range limits, 'r2),
                   'close paren)))

then range max (subtree (r, 'range limits), sn, x)

elseif rule (r,

             prodn (tag ('range limits, 'r),
                   list (tag ('expression, 'lo),
                       'dot dot,
                       tag ('expression, 'hi))))

then precomputable f (subtree i (r, 'expression, 2), sn, x) else not range error (r, sn) endif

; ===========================
;  Range and Default Setting
; ===========================

Definition: value setting (td, v, vkind) = if errorp (v) then v

elseif indeterminate (v) then mk error (v) else let r be in type (td, unmark (v))

in

if truep (r) then value (v) elseif errorp (r) then r else mk error (list (vkind,

unmark (v),

                        'not,
                        'in,
                        'type,

td)) endif endlet endif

Definition: range max setting (td, min, max) = let lo be value setting (td, min, 'range minimum),

hi be value setting (td, max, 'range maximum) in if errorp (hi) then hi elseif errorp (lo) then mk error (marked (lo, unmark (max))) else hi endif endlet

Definition: range min setting (td, min, max) = let lo be value setting (td, min, 'range minimum),

hi be value setting (td, max, 'range maximum) in if errorp (lo) then lo elseif errorp (hi) then mk error (marked (hi, unmark (min))) else lo endif endlet

Definition: set range (td, min, max) = if simple typep (td)

then let lo be range min setting (td, min, max),

hi be range max setting (td, min, max) in if (integerp (lo) ∧ (¬ ileq (lo, hi)))

∨ (rationalp (lo) ∧ (¬ rleq (lo, hi))) then empty type error (set tmin (set tmax (td, hi), lo)) else subrange desc (td, lo, hi) endif endlet

elseif error descp (td) then td

else non simple subrange type error (td) endif

Definition: set default value (td, dv) = if (dv = nil) ∨ error descp (td) then td

else let v be value setting (td, dv,

                            'default initial value)

in

set udv (td, v) endlet endif

; =======================
;  Checking Scalar Types
; =======================

Event: Disable ref.

Event: Disable ref unit.

Event: Disable errorp.

Definition: scalar check (svs, sn, x) = if svs ≃ nil then t

else let r be ref (car (svs), sn, x)

in

if errorp (ref unit (r)) then ref unit (r)

else scalar check (cdr (svs), sn, x) endif endlet endif Definition: construct scalar desc (tn, sn, svs, x) = let err be scalar check (svs, sn, x)

in

if errorp (err) then err

else scalar desc (tn, sn, length (svs)) endif endlet

; ====================
;  Function Type_Desc
; ====================

Event: Disable *1*boolean desc. Event: Disable *1*character desc. Event: Disable *1*integer desc. Event: Disable *1*rational desc. Event: Disable array desc. Event: Disable available types. Event: Disable boolean desc. Event: Disable character desc. Event: Disable construct scalar desc. Event: Disable default initial value. Event: Disable error descp. Event: Disable errorp. Event: Disable gname.

Event: Disable identifierp. Event: Disable integer desc. Event: Disable kind. Event: Disable length. Event: Disable mapping desc. Event: Disable ncopies. Event: Disable not record fields error. Event: Disable not type error. Event: Disable pair list map. Event: Disable pending desc. Event: Disable pending type defnp. Event: Disable range max. Event: Disable range min. Event: Disable rational desc. Event: Disable record desc. Event: Disable record field names. Event: Disable ref. Event: Disable ref scope.

Event: Disable ref unit. Event: Disable scalar type defnp. Event: Disable scalar value list. Event: Disable sequence desc. Event: Disable set default value. Event: Disable set desc. Event: Disable set range. Event: Disable size limit. Event: Disable type defn cycle error. Event: Disable unit name.

#|
(do-mutual '(
(defn field_descs (s sn ut x)
  (if (rule s (prodn (tag 'fields 'f)
     (list (tag 'fields 'f2) 'SEMI_COLON
   (tag 'similar_fields 's))))
      (let ((f1 (field_descs (subtree s 'fields) sn ut x))
    (f2 (field_descs (subtree s 'similar_fields) sn ut x)))
(if (error_descp f1)
    f1
(if (error_descp f2)
    f2
  (append f1 f2))))
  (if (rule s (prodn (tag 'fields 'f)
     (tag 'similar_fields 's)))

    (field_descs (subtree s 'similar_fields) sn ut x)
(if (rule s (prodn (tag 'similar_fields 's)
   (list (tag 'identifier_list 'is) 'COLON
 (tag 'type_specification 'ft))))
    (let ((ftd (type_desc (subtree s 'type_specification) sn ut x))
  (fns (record_field_names (subtree s 'identifier_list))))
(if (error_descp ftd)
  ftd
(pair_list_map fns (ncopies (length fns) ftd))))
  (not_record_fields_error s sn))))
( (ord-lessp (cons (add1 (length (available_types ut x)))
   (tree_size s))) ))

(defn type_desc (s sn ut x)
; sn is the name of the scope where s is to be interpreted
; s is a type specification parse tree or a parse tree that arises in its
;   interpretation
; ut (used types) is a list of types that have already been looked up in x
; x is the Gypsy parse tree
(if (rule s (prodn (tag 'array_type 'a)
   (list 'ARRAY 'OPEN_PAREN (tag 'type_specification 'it)
 'CLOSE_PAREN 'OF (tag 'type_specification 'ct))))
    (array_desc (type_desc (subtree_i s 'type_specification 1) sn ut x)
(type_desc (subtree_i s 'type_specification 2) sn ut x))
(if (rule s (prodn (tag 'mapping_type 'm)
   (list 'MAPPING (tag 'opt_size_limit_restriction 'r)
 'FROM (tag 'type_specification 'st)
 'TO (tag 'type_specification 'ct))))
    (mapping_desc (size_limit (subtree s 'opt_size_limit_restriction) sn x)
  (type_desc (subtree_i s 'type_specification 1) sn ut x)
  (type_desc (subtree_i s 'type_specification 2) sn ut x))
(if (rule s (prodn (tag 'record_type 'r)
   (list 'RECORD 'OPEN_PAREN (tag 'fields 'f)
 'CLOSE_PAREN)))
    (record_desc (field_descs (subtree s 'fields) sn ut x))
(if (rule s (prodn (tag 'sequence_type 's)

(list 'SEQUENCE (tag 'opt_size_limit_restriction 'r)
'OF (tag 'type_specification 'ct))))
 (sequence_desc (size_limit (subtree s 'opt_size_limit_restriction)
sn x)
(type_desc (subtree s 'type_specification) sn ut x))
(if (rule s (prodn (tag 'set_type 's)
(list 'SET (tag 'opt_size_limit_restriction 'r)
'OF (tag 'type_specification 'ct))))
 (set_desc (size_limit (subtree s 'opt_size_limit_restriction) sn x)
(type_desc (subtree s 'type_specification) sn ut x))
(if (rule s (prodn (tag 'type_declaration 'd)
(list 'TYPE (tag 'IDENTIFIER 'tn) 'EQUAL
(tag 'type_definition 'd2))))
 (if (pending_type_defnp s)
(pending_desc (unit_name s) sn)
 (if (scalar_type_defnp s)
(construct_scalar_desc (unit_name s) sn (scalar_value_list s) x)
(type_desc (subtree s 'type_definition) sn ut x)))
(if (rule s (prodn (tag 'type_definition 'd)
(tag 'array_type 'a)))
 (type_desc (subtree s 'array_type) sn ut x)
(if (rule s (prodn (tag 'type_definition 'd)
(tag 'record_type 'r)))
 (type_desc (subtree s 'record_type) sn ut x)
(if (rule s (prodn (tag 'type_definition 'd)
(tag 'mapping_type 'm)))
 (type_desc (subtree s 'mapping_type) sn ut x)
(if (rule s (prodn (tag 'type_definition 'd)
(tag 'sequence_type 's)))
 (type_desc (subtree s 'sequence_type) sn ut x)
(if (rule s (prodn (tag 'type_definition 'd)
(tag 'set_type 's)))
 (type_desc (subtree s 'set_type) sn ut x)
(if (rule s (prodn (tag 'type_definition 's)
(list (tag 'type_specification 's)
(tag 'opt_default_initial_value_expression 'v))))

      (set_default_value (type_desc (subtree s 'type_specification) sn ut x)
 ; set_default_value does not change the default
 ; value if (default_initial_value ...) is nil
 (default_initial_value
   (subtree s 'opt_default_initial_value_expression)
   sn x))
  (if (rule s (prodn (tag 'type_specification 's)
     (tag 'IDENTIFIER 'tn)))
      (type_desc (subtree s 'IDENTIFIER) sn ut x)
  (if (rule s (prodn (tag 'type_specification 's)
     (list (tag 'IDENTIFIER 'tn) (tag 'range 'r))))
      (set_range (type_desc (subtree s 'IDENTIFIER) sn ut x)
 (range_min (subtree s 'range) sn x)
 (range_max (subtree s 'range) sn x))
  (if (identifierp s)
      (let ((tn (gname s)))
(if (equal tn 'boolean)
    (boolean_desc)
(if (equal tn 'character)
    (character_desc)
(if (equal tn 'integer)
    (integer_desc)
(if (equal tn 'rational)
    (rational_desc)
  (let ((r (ref tn sn x)))
  (let ((h (ref_scope r))
(u (ref_unit r)))
    (if (member r ut)
(type_defn_cycle_error tn sn)
    (if (equal (kind u) 'type)
(type_desc u h (cons r ut) x)
    (if (errorp u)
u
      (not_type_error tn sn)))))))))))
    (not_type_error s sn))))))))))))))))
  ( (ord-lessp (cons (add1 (length (available_types ut x)))
     (tree_size s))) ))
))

|#

Definition: mutual-type desc-field descs (mutual-flg, s, sn, ut, x) = if mutual-flg = 'type desc

then if rule (s,

prodn (tag ('array type, 'a),

list ('array,
'open paren,
tag ('type specification, 'it),
'close paren,
'of,
tag ('type specification, 'ct))))

then array desc (mutual-type desc-field descs ('type desc,

subtree i (s,

        'type specification,

1),

sn, ut, x),

mutual-type desc-field descs ('type desc,

subtree i (s,

        'type specification,

2),

sn, ut, x))

elseif rule (s,

prodn (tag ('mapping type, 'm),
list ('mapping,
tag ('opt size limit restriction,
'r),
'from,
tag ('type specification, 'st),
'to,
tag ('type specification, 'ct))))

then mapping desc (size limit (subtree (s,

'opt size limit restriction),

sn, x),

mutual-type desc-field descs ('type desc,

subtree i (s,

           'type specification,

sn, ut, x),

mutual-type desc-field descs ('type desc,

subtree i (s,

        'type specification,

2),

sn, ut, x))

elseif rule (s,

prodn (tag ('record type, 'r),
list ('record,
'open paren,
tag ('fields, 'f),
'close paren)))

then record desc (mutual-type desc-field descs ('field descs,

subtree (s,

     'fields),

sn, ut, x))

elseif rule (s,

prodn (tag ('sequence type, 's),
list ('sequence,
tag ('opt size limit restriction,
'r),
'of,
tag ('type specification, 'ct))))

then sequence desc (size limit (subtree (s,

'opt size limit restriction),

sn, x),

mutual-type desc-field descs ('type desc,

subtree (s,

       'type specification),

sn, ut, x))

elseif rule (s,

prodn (tag ('set type, 's),

list ('set,

tag ('opt size limit restriction,

                       'r),
                   'of,
                   tag ('type specification, 'ct))))

then set desc (size limit (subtree (s,

                            'opt size limit restriction),

sn, x),

mutual-type desc-field descs ('type desc,

subtree (s,

                                            'type specification),

sn, ut, x))

elseif rule (s,

          prodn (tag ('type declaration, 'd),

list ('type,

                   tag ('identifier, 'tn),
                   'equal,
                   tag ('type definition, 'd2))))

then if pending type defnp (s) then pending desc (unit name (s), sn) elseif scalar type defnp (s) then construct scalar desc (unit name (s),

sn,

scalar value list (s), x)

else mutual-type desc-field descs ('type desc,

subtree (s,

                                         'type definition),

sn, ut,

x) endif

elseif rule (s,

          prodn (tag ('type definition, 'd),
                tag ('array type, 'a)))

then mutual-type desc-field descs ('type desc, subtree (s, 'array type), sn, ut, x)

elseif rule (s,

          prodn (tag ('type definition, 'd),
                tag ('record type, 'r)))

then mutual-type desc-field descs ('type desc, subtree (s, 'record type), sn, ut, x)

elseif rule (s,

prodn (tag ('type definition, 'd),
tag ('mapping type, 'm)))

then mutual-type desc-field descs ('type desc,

subtree (s, 'mapping type),

sn, ut, x)

elseif rule (s,

prodn (tag ('type definition, 'd),
tag ('sequence type, 's)))

then mutual-type desc-field descs ('type desc,

subtree (s, 'sequence type),

sn, ut, x)

elseif rule (s,

prodn (tag ('type definition, 'd),
tag ('set type, 's)))

then mutual-type desc-field descs ('type desc, subtree (s, 'set type), sn, ut, x)

elseif rule (s,

prodn (tag ('type definition, 's),
list (tag ('type specification, 's),
tag ('opt default initial value expression,

'v))))

then set default value (mutual-type desc-field descs ('type desc,

subtree (s,

                      'type specification),

sn, ut, x),

default initial value (subtree (s,

               'opt default initial value expression),

sn, x))

elseif rule (s,

prodn (tag ('type specification, 's),

           tag ('identifier, 'tn)))

then mutual-type desc-field descs ('type desc, subtree (s, 'identifier), sn, ut, x)

elseif rule (s,

     prodn (tag ('type specification, 's),
           list (tag ('identifier, 'tn),

tag ('range, 'r))))

then set range (mutual-type desc-field descs ('type desc,

subtree (s,

                                        'identifier),

sn, ut, x),

range min (subtree (s, 'range), sn, x), range max (subtree (s, 'range), sn, x))

elseif identifierp (s) then case on gname (s):

case = boolean then boolean desc case = character then character desc case = integer then integer desc case = rational then rational desc otherwise if ref (gname (s), sn, x) ∈ ut

then type defn cycle error (gname (s), sn) elseif kind (ref unit (ref (gname (s), sn, x)))

               = 'type

then mutual-type desc-field descs ('type desc,

ref unit (ref (gname (s), sn, x)), ref scope (ref (gname (s),

sn, x)),

cons (ref (gname (s), sn, x),

ut), x) elseif errorp (ref unit (ref (gname (s), sn, x))) then ref unit (ref (gname (s), sn, x)) else not type error (gname (s), sn) endif endcase

else not type error (s, sn) endif elseif rule (s,

prodn (tag ('fields, 'f),

list (tag ('fields, 'f2),

'semi colon,
tag ('similar fields, 's))))

then if error descp (mutual-type desc-field descs ('field descs, subtree (s, 'fields), sn, ut, x))

then mutual-type desc-field descs ('field descs, subtree (s, 'fields), sn, ut, x)

elseif error descp (mutual-type desc-field descs ('field descs,

subtree (s,

                  'similar fields),

sn, ut, x))

then mutual-type desc-field descs ('field descs,

subtree (s, 'similar fields),

sn, ut, x)

else append (mutual-type desc-field descs ('field descs,

subtree (s,

             'fields),

sn, ut, x),

mutual-type desc-field descs ('field descs,

subtree (s,

             'similar fields),

sn, ut, x)) endif

elseif rule (s, prodn (tag ('fields, 'f), tag ('similar fields, 's))) then mutual-type desc-field descs ('field descs,

                                 subtree (s, 'similar fields),

sn, ut, x)

elseif rule (s,

             prodn (tag ('similar fields, 's),
                   list (tag ('identifier list, 'is),
                       'colon,
                       tag ('type specification, 'ft))))

then if error descp (mutual-type desc-field descs ('type desc,

subtree (s,

                                                     'type specification),

sn, ut, x))

then mutual-type desc-field descs ('type desc,

subtree (s,

                                             'type specification),

sn, ut, x)

else pair list map (record field names (subtree (s,

                                                'identifier list)),

ncopies (length (record field names (subtree (s,

                                                             'identifier list))),

mutual-type desc-field descs ('type desc,

subtree (s,

                                                               'type specification),

sn, ut, x))) endif

else not record fields error (s, sn) endif

Definition: type desc (s, sn, ut, x) = mutual-type desc-field descs ('type desc, s, sn, ut, x)

Definition: field descs (s, sn, ut, x) = mutual-type desc-field descs ('field descs, s, sn, ut, x)

; ****************
;  Literal Values
; ****************

; ----------------
;  Boolean Values
; ----------------

Definition: gfalse = marked (nil, typed (boolean desc, 0))

Definition: gtrue = marked (nil, typed (boolean desc, 1))

Definition: gtruep (v) = (determinate (v)

∧ truep (in type (boolean desc, v))

∧ (value (v) = value (gtrue)))

; ------------------
;  Character Values
; ------------------

Definition: gchar (c) = if character valuep (c)

then marked (nil, typed (character desc, cadr (lexeme (c))))

else marked (character error (c), default value (character desc)) endif

; --------------------------------
;  Numbers - Integer and Rational
; --------------------------------

Definition: gizero = marked (nil, typed (integer desc, 0))

Definition: grzero = marked (nil, typed (rational desc, rational (0, 1)))

Definition: gione = marked (nil, typed (integer desc, 1))

Definition: gitwo = marked (nil, typed (integer desc, 2))

Definition: char digit (c) = if (ascii 0 ≤ c) ∧ (c ≤ ascii 9) then c − ascii 0

elseif (ascii a ≤ c) ∧ (c ≤ ascii f)

then (c − ascii a) + 10

elseif (ascii lc a ≤ c) ∧ (c ≤ ascii lc f)

then (c − ascii lc a) + 10

else nil endif Definition: digit valid (d, b) = let n be char digit (d)

in

(n ∈ N) ∧ (0 ≤ n) ∧ (n < b) endlet

Event: Disable digit valid.

Event: Disable char digit.

Definition: digit value (s, b) = if s ≃ nil then 0

elseif digit value (rcdr (s), b) = 'ind then 'ind

elseif digit valid (rcar (s), b)

then (digit value (rcdr (s), b) ∗ b) + char digit (rcar (s))

else 'ind endif

Definition: tdigit value (s, b) = if digit listp (s) then digit value (lexeme (s), b)

else 'ind endif

Definition: mdigit value (s, b) = if tdigit value (s, b) = 'ind

then marked (number error (s, b), default value (integer desc)) else marked (nil, typed (integer desc, tdigit value (s, b))) endif

Definition: minteger (i) = if rule (i, prodn (tag ('number, 'n), tag ('digit list, 's)))

then mdigit value (subtree (i, 'digit list), 10) elseif digit listp (i) then mdigit value (i, 10) elseif rule (i,

prodn (tag ('number, 'n),

list (tag ('base, 'b), tag ('digit list, 's))))

then mdigit value (subtree (i, 'digit list), ibase (subtree (i, 'base))) else marked (number error (i, 10), default value (integer desc)) endif

; ---------------
;  String Values
; ---------------

Definition: string char seq (s) = if s ≃ nil then nil

elseif car (s) = ascii double quote

then cons (car (s), string char seq (cddr (s))) else cons (car (s), string char seq (cdr (s))) endif

Definition: gstring seq (s) = if string valuep (s)

then marked (nil,

typed (sequence desc (nil, character desc),

string char seq (rcdr (cdr (lexeme (s))))))

else marked (bad string error (s), default value (sequence desc (nil, character desc))) endif

; ***************************************
;  Arguments to Functions and Operations
; ***************************************

Definition: in arg type (td, a)

= if td = 'field name

then (mark (a) = td) ∧ litatom (unmark (a))

    elseif td = 'type descriptor

then (mark (a) = td) ∧ type descp (unmark (a))

else in type (td, a) endif

Definition: arg check (as, ts) = if as ≃ nil

then if ts ≃ nil then nil

         else mk error ('(number of formal and actual
                       parameters not equal)) endif

elseif ts ≃ nil

    then mk error ('(number of formal and actual parameters
                   not equal))

elseif indeterminate (car (as)) then mark (car (as))

else let r be in arg type (car (ts), car (as))

in

if truep (r) then arg check (cdr (as), cdr (ts))

elseif errorp (r) then r

else actual formal type error (car (as), car (ts)) endif endlet endif

; ******************
;  Gypsy Operations
; ******************
; ---------------------
;  Component Selection
; ---------------------

Definition: array get (a, i, td) = let arg err be arg check (list (a, i), list (td, selector td (td)))

in

if arg err = nil

then if array descp (td)

then marked (nil,

typed (component td (td),

vselect (value (a), value (i), td)))

else marked (not array error (a),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: mapping get (m, d, td) = let arg err be arg check (list (m, d), list (td, selector td (td)))

in

if arg err = nil

then if mapping descp (td)

then let v be vselect (value (m), value (d), td) in if errorp (v) then marked (no such component error (m, d),

default value (component td (td)))

else marked (nil,

typed (component td (td), v)) endif endlet

else marked (not mapping error (m),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: record get (r, fn, td) = let arg err be arg check (list (r, fn), list (td, 'field name))

in

if arg err = nil

then if record descp (td) then let fd be field td (unmark (fn), td)

in

if fd = nil

then marked (no such field error (r, unmark (fn)),

default value (integer desc))

else marked (nil,

typed (fd,

fselect (value (r),

unmark (fn)))) endif endlet

else marked (not record error (r),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: sequence get (s, i, td) = let arg err be arg check (list (s, i), list (td, integer desc))

in

if arg err = nil

then if sequence descp (td)

then let v be vselect (value (s), value (i), td) in if errorp (v) then marked (no such component error (s, i),

default value (component td (td)))

else marked (nil,

typed (component td (td), v)) endif endlet

else marked (not sequence error (s),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Event: Disable type.

Event: Disable array get.

Event: Disable record get.

Event: Disable mapping get.

Event: Disable sequence get.

Event: Disable not selectable error.

Event: Disable default value.

Definition: select op (v, s) = if s ≃ nil then v

else case on root (type (v)): case = array then select op (array get (v, car (s), type (v)), cdr (s)) case = record then select op (record get (v, car (s), type (v)), cdr (s)) case = mapping then select op (mapping get (v, car (s), type (v)), cdr (s)) case = sequence then select op (sequence get (v, car (s), type (v)), cdr (s)) otherwise marked (not selectable error (v),

default value (integer desc)) endcase endif

; ---------------------------
;  Sequence/Set Constructors
; ---------------------------

Definition: gseq (es, td) = let arg err be arg check (es, ncopies (length (es), td))

in

if arg err = nil

then marked (nil, typed (sequence desc (nil, td), values (es))) else marked (arg err, default value (integer desc)) endif endlet

Definition: gset (es, td) = let arg err be arg check (es, ncopies (length (es), td))

in

if arg err = nil

then marked (nil, typed (set desc (nil, td), vset (values (es), td))) else marked (arg err, default value (integer desc)) endif endlet

Definition: grange elements (lo, hi) = let arg err be arg check (list (lo, hi),

list (base type (type (lo)), base type (type (lo))))

in if arg err = nil then if non rational simple typep (type (lo))

then marked typed list (base type (type (lo)),

number list (value (lo), value (hi)))

else list (marked (range limits error (lo, hi),

default value (base type (type (lo))))) endif

else list (marked (arg err, default value (base type (type (lo))))) endif endlet

Definition: gset or seq (m, a, td) = if rule (m, prodn (tag ('set or seq mark, 'm), list ('set, 'colon)))

then gset (a, td) elseif rule (m,

             prodn (tag ('set or seq mark, 'm), list ('seq, 'colon)))

then gseq (a, td) else gseq (a, td) endif

; ------------------------------------
;  Interface to Boyer-Moore Functions
; ------------------------------------

Definition: t or f (x) = if x ≃ 0 then f

else t endif

Definition: band (x, y) = (t or f (x) ∧ t or f (y))

Definition: bimp (x, y) = (t or f (x) → t or f (y))

Definition: bnot (x) = (¬ t or f (x))

Definition: bor (x, y) = (t or f (x) ∨ t or f (y))

; -----------------
;  Unary Operators
; -----------------

Definition: gminus (u) = let iarg err be arg check (list (u), list (integer desc)),

rarg err be arg check (list (u), list (rational desc)) in if iarg err = nil then marked (nil, typed (integer desc, ineg (value (u)))) elseif rarg err = nil then marked (nil, typed (rational desc, rneg (value (u)))) else marked (mk error (list (iarg err, rarg err)),

default value (integer desc)) endif endlet

Definition: gnot (u) = let arg err be arg check (list (u), list (boolean desc))

in if arg err = nil then if bnot (value (u)) then gtrue

else gfalse endif else marked (arg err, default value (boolean desc)) endif endlet

Definition: apply unary op (op, v) = if rule (op, prodn (tag ('unary operator, 'op), 'minus))

then gminus (v) elseif rule (op, prodn (tag ('unary operator, 'op), 'not)) then gnot (v) else marked (not unary op error (op), default value (integer desc)) endif

; ------------------
;  Binary Operators
; ------------------

Definition: gequal (v1 , v2 ) = if equality typep (type (v1 ))

then let td be base type (type (v1 ))

in

let arg err be arg check (list (v1 , v2 ), list (td, td)) in if arg err = nil then if vequal (value (v1 ), value (v2 ), td) then gtrue

else gfalse endif else marked (arg err,

default value (boolean desc)) endif endlet endlet

else marked (not equality type error (type (v1 )), default value (boolean desc)) endif

Definition: gne (v1 , v2 ) = gnot (gequal (v1 , v2 ))

Definition: glt (v1 , v2 ) = let td be base type (type (v1 ))

in let arg err be arg check (list (v1 , v2 ), list (td, td)) in if arg err = nil then if simple typep (td)

then let r be if root (td) = 'rational then rlessp (value (v1 ), value (v2 )) else ilessp (value (v1 ),

value (v2 )) endif

in

if truep (r) then gtrue else gfalse endif endlet

else marked (not defined on type error ('lt,

type (v1 )),

default value (boolean desc)) endif

else marked (arg err, default value (boolean desc)) endif endlet endlet

Definition: gor (v1 , v2 ) = let arg err be arg check (list (v1 , v2 ),

list (boolean desc, boolean desc))

in if arg err = nil then if bor (value (v1 ), value (v2 )) then gtrue

else gfalse endif else marked (arg err, default value (boolean desc)) endif endlet

Definition: gle (v1 , v2 ) = gor (glt (v1 , v2 ), gequal (v1 , v2 ))

Definition: ggt (v1 , v2 ) = glt (v2 , v1 )

Definition: gge (v1 , v2 ) = gor (ggt (v1 , v2 ), gequal (v1 , v2 ))

Definition: gand (v1 , v2 ) = let arg err be arg check (list (v1 , v2 ),

list (boolean desc, boolean desc))

in if arg err = nil then if band (value (v1 ), value (v2 )) then gtrue

else gfalse endif else marked (arg err, default value (boolean desc)) endif endlet Definition: gimp (v1 , v2 ) = let arg err be arg check (list (v1 , v2 ),

list (boolean desc, boolean desc))

in if arg err = nil then if bimp (value (v1 ), value (v2 )) then gtrue

else gfalse endif else marked (arg err, default value (boolean desc)) endif endlet

Definition: giff (v1 , v2 ) = let arg err be arg check (list (v1 , v2 ),

list (boolean desc, boolean desc))

in if arg err = nil then gequal (v1 , v2 ) else marked (arg err, default value (boolean desc)) endif endlet

Definition: gpower (v1 , v2 ) = let iarg err be arg check (list (v1 , v2 ),

list (integer desc, integer desc)),

rarg err be arg check (list (v1 , v2 ),

list (rational desc, integer desc))

in if iarg err = nil then if gtruep (glt (v2 , gizero))

then marked (negative exponent error,

default value (integer desc)) elseif gtruep (gand (gequal (v1 , gizero), gequal (v2 , gizero))) then marked (zero to the zero power error,

default value (integer desc))

else marked (nil,

typed (integer desc,

ipower (value (v1 ), value (v2 )))) endif

elseif rarg err = nil then if gtruep (glt (v2 , gizero))

then marked (negative exponent error,

default value (rational desc)) elseif gtruep (gand (gequal (v1 , grzero), gequal (v2 , gizero))) then marked (zero to the zero power error,

default value (rational desc))

else marked (nil, typed (rational desc,

rpower (value (v1 ), value (v2 )))) endif

else marked (mk error (list (iarg err, rarg err)), default value (integer desc)) endif endlet

Definition: gtimes (v1 , v2 ) = let iarg err be arg check (list (v1 , v2 ),

list (integer desc, integer desc)),

rarg err be arg check (list (v1 , v2 ),

list (rational desc, rational desc))

in if iarg err = nil then marked (nil,

typed (integer desc, itimes (value (v1 ), value (v2 ))))

elseif rarg err = nil then marked (nil,

typed (rational desc, rtimes (value (v1 ), value (v2 ))))

else marked (mk error (list (iarg err, rarg err)), default value (integer desc)) endif endlet

Definition: gquotient (v1 , v2 ) = let iarg err be arg check (list (v1 , v2 ),

list (integer desc, integer desc)),

rarg err be arg check (list (v1 , v2 ),

list (rational desc, rational desc))

in if iarg err = nil then if izerop (value (v2 ))

then marked (zero divide error,

default value (rational desc))

else marked (nil,

typed (rational desc,

reduce (rational (value (v1 ),

value (v2 ))))) endif

elseif rarg err = nil then if rzerop (value (v2 ))

then marked (zero divide error,

default value (rational desc))

else marked (nil,

typed (rational desc,

rquotient (value (v1 ), value (v2 )))) endif

else marked (mk error (list (iarg err, rarg err)), default value (rational desc)) endif endlet Definition: gdiv (v1 , v2 ) = let arg err be arg check (list (v1 , v2 ),

list (integer desc, integer desc))

in if arg err = nil then if izerop (value (v2 ))

then marked (zero divide error, default value (integer desc)) else marked (nil,

typed (integer desc,

iquotient (value (v1 ), value (v2 )))) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: gmod (v1 , v2 ) = let arg err be arg check (list (v1 , v2 ),

list (integer desc, integer desc))

in if arg err = nil then if izerop (value (v2 ))

then marked (zero divide error, default value (integer desc)) else marked (nil,

typed (integer desc,

iremainder (value (v1 ), value (v2 )))) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: gplus (v1 , v2 ) = let iarg err be arg check (list (v1 , v2 ),

list (integer desc, integer desc)),

rarg err be arg check (list (v1 , v2 ),

list (rational desc, rational desc))

in if iarg err = nil then marked (nil, typed (integer desc, iplus (value (v1 ), value (v2 )))) elseif rarg err = nil then marked (nil,

typed (rational desc, rplus (value (v1 ), value (v2 ))))

else marked (mk error (list (iarg err, rarg err)), default value (integer desc)) endif endlet

Definition: gsubtract (v1 , v2 ) = let iarg err be arg check (list (v1 , v2 ),

list (integer desc, integer desc)), rarg err be arg check (list (v1 , v2 ),

list (rational desc, rational desc))

in if iarg err = nil then marked (nil,

typed (integer desc,

idifference (value (v1 ), value (v2 ))))

elseif rarg err = nil then marked (nil,

typed (rational desc,

rdifference (value (v1 ), value (v2 ))))

else marked (mk error (list (iarg err, rarg err)), default value (integer desc)) endif endlet

Definition: gin (v1 , v2 ) = let td be base type (type (v2 ))

in if sequence descp (td) ∨ set descp (td) then let arg err be arg check (list (v1 , v2 ),

list (component td (td), td))

in

if arg err = nil

then if vmember (value (v1 ), value (v2 ), component td (td)) then gtrue

else gfalse endif else marked (arg err,

default value (boolean desc)) endif endlet

else marked (in arg error (v2 ), default value (boolean desc)) endif endlet

Definition: mapping merge arg check2 (ks, v1 , v2 ) = if ks ≃ nil then t

else let c1 be mapping get (v1 , car (ks), base type (type (v1 ))),

c2 be mapping get (v2 , car (ks), base type (type (v2 ))) in if determinate (c1 ) ∧ determinate (c2 ) then gtruep (gequal (c1 , c2 ))

∧ mapping merge arg check2 (cdr (ks), v1 , v2 ) else mapping merge arg check2 (cdr (ks), v1 , v2 ) endif endlet endif

Definition: mapping merge arg check (v1 , v2 ) = if mapping descp (type (v1 )) ∧ mapping descp (type (v2 )) then let ks be marked typed list (selector td (base type (type (v1 ))),

vdomain (value (v1 )))

in

mapping merge arg check2 (ks, v1 , v2 ) endlet else f endif

Definition: gunion (v1 , v2 ) = let td be base type (type (v1 ))

in let arg err be arg check (list (v1 , v2 ), list (td, td)) in if arg err = nil then if set descp (td)

then marked (nil,

typed (td,

vunion (value (v1 ), value (v2 ), td)))

elseif mapping descp (td)

then if mapping merge arg check (v1 , v2 )

then marked (nil,

typed (td,

vunion maps (value (v1 ), value (v2 ), td)))

else marked (mapping merge error (v1 , v2 ),

default value (td)) endif

else marked (union arg error (v1 , v2 ),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: gadjoin (v1 , v2 ) = if set descp (type (v1 ))

then gunion (v1 , gset (list (v2 ), base type (type (v2 )))) else marked (adjoin args error (v1 ), default value (integer desc)) endif

Definition: gomit (v1 , v2 ) = let td be base type (type (v1 ))

in if set descp (td) then let arg err be arg check (list (v1 , v2 ),

list (td, component td (td)))

in

if arg err = nil then if gtruep (gin (v2 , v1 )) then marked (nil,

typed (td,

vremove (value (v2 ), value (v1 ), component td (td))))

else marked (not in set error (v2 , v1 ),

default value (td)) endif

else marked (arg err,

default value (integer desc)) endif endlet

else marked (omit args error (v1 ), default value (integer desc)) endif endlet

Definition: gsub (v1 , v2 ) = let td be base type (type (v1 ))

in let arg err be arg check (list (v1 , v2 ), list (td, td)) in if arg err = nil then if mapping descp (td)

∨ sequence descp (td)

∨ set descp (td) then if vsubp (value (v1 ), value (v2 ), td) then gtrue

else gfalse endif else marked (sub args error (v1 , v2 ),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: gintersect (v1 , v2 ) = let td be base type (type (v1 ))

in let arg err be arg check (list (v1 , v2 ), list (td, td)) in if arg err = nil then if set descp (td)

then marked (nil,

typed (td,

vintersect (value (v1 ), value (v2 ), td)))

elseif mapping descp (td)

then if mapping merge arg check (v1 , v2 ) then marked (nil,

typed (td,

vintersect maps (value (v1 ), value (v2 ), td)))

else marked (mapping merge error (v1 , v2 ),

default value (td)) endif

else marked (intersect args error (v1 , v2 ),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: gdifference (v1 , v2 ) = let td be base type (type (v1 ))

in let arg err be arg check (list (v1 , v2 ), list (td, td)) in if arg err = nil then if set descp (td)

then marked (nil,

typed (td,

vdifference (value (v1 ), value (v2 ), td)))

elseif mapping descp (td)

then if mapping merge arg check (v1 , v2 )

then marked (nil,

typed (td,

vdifference maps (value (v1 ), value (v2 ), td)))

else marked (mapping merge error (v1 , v2 ),

default value (td)) endif

else marked (difference args error (v1 , v2 ),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: gappend (v1 , v2 ) = let td be base type (type (v1 ))

in let arg err be arg check (list (v1 , v2 ), list (td, td)) in if arg err = nil then if sequence descp (td)

then marked (nil,

typed (td, append (value (v1 ), value (v2 ))))

else marked (append args error (v1 , v2 ),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: gcons (v1 , v2 ) = gappend (gseq (list (v1 ), base type (type (v1 ))), v2 )

Definition: grcons (v1 , v2 ) = gappend (v1 , gseq (list (v2 ), base type (type (v2 ))))

Definition: apply binary op (op, v1 , v2 ) = if rule (op, prodn (tag ('binary operator, 'op), 'eq))

  ∨ rule (op, prodn (tag ('binary operator, 'op), 'equal))

then gequal (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'ne)) then gne (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'lt)) then glt (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'le)) then gle (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'gt)) then ggt (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'ge)) then gge (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'and)) then gand (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'or)) then gor (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'imp)) then gimp (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'iff)) then giff (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'star star)) then gpower (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'star)) then gtimes (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'slash)) then gquotient (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'div)) then gdiv (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'mod)) then gmod (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'plus)) then gplus (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'minus)) then gsubtract (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'in)) then gin (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'adjoin)) then gadjoin (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'omit)) then gomit (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'sub)) then gsub (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'union)) then gunion (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'intersect)) then gintersect (v1 , v2 )

elseif rule (op, prodn (tag ('binary operator, 'op), 'difference))

then gdifference (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'colon gt)) then gcons (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'lt colon)) then grcons (v1 , v2 ) elseif rule (op, prodn (tag ('binary operator, 'op), 'append)) then gappend (v1 , v2 ) else marked (not binary op error (op), default value (integer desc)) endif

; -----------------------
;  Subsequence Selection
; -----------------------

Definition: subsequence get (s, lo, hi) = let arg err be arg check (list (s, lo, hi),

list (type (s), integer desc, integer desc))

in if arg err = nil then if sequence descp (type (s))

then if gtruep (gle (lo, hi))

then if indeterminate (sequence get (s, lo, type (s)))

then marked (no such component error (s, lo),

default value (type (s))) elseif indeterminate (sequence get (s, hi, type (s))) then marked (no such component error (s, hi),

default value (type (s)))

else marked (nil,

typed (type (s),

vsubseq select (value (s), value (lo), value (hi)))) endif

else marked (nil, typed (type (s), null seq)) endif else marked (not sequence error (s),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

; ------------------
;  Value Alteration
; ------------------

Definition: array put (a, i, v) = let td be base type (type (a))

in let arg err be arg check (list (a, i, v),

list (td, selector td (td), component td (td)))

in if arg err = nil then if array descp (td)

then marked (nil,

typed (td,

varray put (value (a), value (i), value (v), td)))

else marked (not array error (a),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: record put (r, fn, v) = let td be base type (type (r))

in let arg err be arg check (list (r, fn, v),

list (td,

                          'field name,

field td (unmark (fn), td)))

in if arg err = nil then if record descp (td)

then marked (nil,

typed (td,

vrecord put (value (r), unmark (fn), value (v))))

else marked (not record error (r),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: mapping put (m, d, v) = let td be base type (type (m))

in let arg err be arg check (list (m, d, v),

list (td, selector td (td), component td (td)))

in if arg err = nil then if mapping descp (td)

then if determinate (mapping get (m, d, type (m)))

then marked (nil,

typed (td,

vmapping put (value (m), value (d), value (v), td)))

else marked (no such component error (m, d), default value (td)) endif

else marked (not mapping error (m),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: sequence put (s, i, v) = let td be base type (type (s))

in let arg err be arg check (list (s, i, v),

list (td, integer desc,

component td (td)))

in if arg err = nil then if sequence descp (td)

then if determinate (sequence get (s, i, type (s)))

then marked (nil,

typed (td,

vsequence put (value (s), value (i), value (v))))

else marked (no such component error (s, i),

default value (td)) endif

else marked (not sequence error (s),

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: put op (bv, s, v) = if s ≃ nil then v

else case on root (type (bv)):

case = array

then array put (bv, car (s), put op (array get (bv, car (s), type (bv)),

cdr (s), v))

case = record

then record put (bv, car (s), put op (record get (bv, car (s), type (bv)),

cdr (s), v))

case = mapping then mapping put (bv,

car (s),

put op (mapping get (bv, car (s), type (bv)), cdr (s), v))

case = sequence then sequence put (bv,

car (s),

put op (sequence get (bv, car (s), type (bv)), cdr (s), v)) otherwise marked (component assign error (bv),

default value (integer desc)) endcase endif

Definition: gmapomit (m, i) = if determinate (mapping get (m, i, type (m)))

then marked (nil, typed (type (m), vmap remove (value (m), value (i), type (m)))) else marked (mark (mapping get (m, i, type (m))),

default value (type (m))) endif

Definition: gseqomit (s, i) = if determinate (sequence get (s, i, type (s)))

then let s2 be gappend (subsequence get (s, gione, gsubtract (i, gione)), subsequence get (s,

gplus (i, gione), marked (nil,

typed (integer desc,

vsize (value (s))))))

in

marked (mark (s2 ), typed (type (s), value (s2 ))) endlet else marked (mark (sequence get (s, i, type (s))),

default value (type (s))) endif

Definition: gmap insert (m, d, v) = let td be base type (type (m))

in

let arg err be arg check (list (m, d, v),

list (td, selector td (td), component td (td)))

in

if arg err = nil

then if mapping descp (td)

then if determinate (mapping get (m, d, type (m))) then mapping put (m, d, v) else marked (nil,

typed (td,

vmapping put (value (m), value (d), value (v), td))) endif

else marked (not mapping error (m), default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: gseq insert before (s, i, v) = if determinate (sequence get (s, i, type (s)))

then gappend (subsequence get (s, gione, gsubtract (i, gione)),

gappend (gseq (list (v), base type (type (v))),

subsequence get (s, i, marked (nil,

typed (integer desc,

vsize (value (s)))))))

else marked (mark (sequence get (s, i, type (s))), default value (base type (type (s)))) endif

Definition: gseq insert behind (s, i, v) = if determinate (sequence get (s, i, type (s)))

then gappend (subsequence get (s, gione, i),

gappend (gseq (list (v), base type (type (v))),

subsequence get (s, gplus (i, gione), marked (nil,

typed (integer desc,

vsize (value (s)))))))

else marked (mark (sequence get (s, i, type (s))), default value (base type (type (s)))) endif

; ********************
;  Standard Functions
; ********************

Definition: std domain (d) = let arg err be arg check (d, list (type (car (d))))

in

if arg err = nil

then if mapping descp (type (car (d)))

then marked (nil,

typed (set desc (nil, selector td (type (car (d)))),

vdomain (value (car (d)))))

else marked (domain arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet Definition: std first (d) = let arg err be arg check (d, list (type (car (d))))

in if arg err = nil then if sequence descp (type (car (d)))

then sequence get (car (d), gione, type (car (d))) else marked (first arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: std initial (d) = let arg err be arg check (d, list ('type descriptor))

in if arg err = nil then let td be unmark (car (d))

in

if errorp (udv (td))

then marked (udv (td), default value (td))

else marked (nil, typed (td, udv (td))) endif endlet else marked (arg err, default value (integer desc)) endif endlet

Definition: std last (d) = let arg err be arg check (d, list (type (car (d))))

in if arg err = nil then if sequence descp (type (car (d)))

then sequence get (car (d),

marked (nil,

typed (integer desc, vsize (car (d)))), type (car (d)))

else marked (last arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: std lower (d) = let arg err be arg check (d, list ('type descriptor))

in if arg err = nil then let td be unmark (car (d))

in

let r be tmin (td) in if r = nil then marked (unbounded type error (td),

default value (td))

elseif errorp (r)

then marked (r, default value (td))

else marked (nil, typed (td, r)) endif endlet endlet else marked (arg err, default value (integer desc)) endif endlet

Definition: std max (d) = let td be base type (type (car (d)))

in let arg err be arg check (d, list (td, td)) in if arg err = nil then if simple typep (td)

then if gtruep (ggt (car (d), cadr (d)))

then marked (nil, typed (td, value (car (d)))) else marked (nil,

typed (td, value (cadr (d)))) endif

else marked (max arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: std min (d) = let td be base type (type (car (d)))

in let arg err be arg check (d, list (td, td)) in if arg err = nil then if simple typep (td)

then if gtruep (glt (car (d), cadr (d)))

then marked (nil, typed (td, value (car (d)))) else marked (nil,

typed (td, value (cadr (d)))) endif

else marked (min arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: std nonfirst (d) = let arg err be arg check (d, list (type (car (d))))

in if arg err = nil then if sequence descp (type (car (d)))

then if 0 = vsize (value (car (d)))

then marked (empty seq error ('nonfirst, car (d)),

default value (type (car (d))))

else subsequence get (car (d), gitwo, marked (nil,

typed (integer desc,

vsize (value (car (d)))))) endif

else marked (nonfirst arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: std nonlast (d) = let arg err be arg check (d, list (type (car (d))))

in if arg err = nil then if sequence descp (type (car (d)))

then if 0 = vsize (value (car (d)))

then marked (empty seq error ('nonlast, car (d)),

default value (type (car (d))))

else subsequence get (car (d), gione, marked (nil,

typed (integer desc,

vsize (value (car (d))) − 1))) endif

else marked (nonlast arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: gnull map (td) = if mapping descp (td)

then let r be dtype (td, null map)

in

if truep (r) then marked (nil, typed (td, null map)) elseif errorp (r) then marked (r, default value (td)) else marked (not in type error (null map, td),

default value (td)) endif endlet

else marked (not mapping type error (td), default value (integer desc)) endif

Definition: gnull seq (td) = if sequence descp (td)

then let r be dtype (td, null seq)

in if truep (r) then marked (nil, typed (td, null seq)) elseif errorp (r) then marked (r, default value (td)) else marked (not in type error (null seq, td),

default value (td)) endif endlet

else marked (not sequence type error (td), default value (integer desc)) endif

Definition: gnull set (td) = if set descp (td)

then let r be dtype (td, null set)

in if truep (r) then marked (nil, typed (td, null set)) elseif errorp (r) then marked (r, default value (td)) else marked (not in type error (null set, td),

default value (td)) endif endlet

else marked (not set type error (td), default value (integer desc)) endif

Definition: std null (d) = let arg err be arg check (d, list ('type descriptor))

in if arg err = nil then let td be unmark (car (d))

in case on root (td): case = mapping then gnull map (td) case = sequence then gnull seq (td) case = set then gnull set (td) otherwise marked (null undefined error (td),

default value (integer desc)) endcase endlet

else marked (arg err, default value (integer desc)) endif endlet

Definition: std ord (d) = let td be type (car (d))

in let arg err be arg check (d, list (td)) in if arg err = nil then if scalar typep (td)

then marked (nil, typed (integer desc, value (car (d)))) else marked (ord arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: std pred (d) = let td be base type (type (car (d)))

in let arg err be arg check (d, list (td)) in if arg err = nil then if scalar typep (td)

then if gtruep (gequal (car (d),

std lower (list (marked ('type descriptor,

td)))))

then marked (lower pred error (td),

default value (td))

else marked (nil,

typed (td, value (car (d)) − 1)) endif

else marked (pred arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet endlet

Definition: std range (d) = let arg err be arg check (d, list (type (car (d))))

in if arg err = nil then if mapping descp (type (car (d)))

then marked (nil,

typed (set desc (nil, component td (type (car (d)))),

vrange (value (car (d)))))

else marked (range arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: std scale (d) = let arg err be arg check (d,

list (integer desc, 'type descriptor))

in if arg err = nil then let td be base type (unmark (cadr (d)))

in if scalar typep (td) then let ok be dtype (td, value (car (d)))

in

if truep (ok)

then marked (nil,

typed (td, value (car (d))))

elseif errorp (ok)

then marked (ok, default value (td))

else marked (scale int arg error (value (car (d)),

td),

default value (td)) endif endlet

else marked (scale type arg error (td),

default value (integer desc)) endif endlet

else marked (arg err, default value (integer desc)) endif endlet

Definition: std size (d) = let arg err be arg check (d, list (type (car (d))))

in if arg err = nil then if mapping descp (type (car (d)))

∨ sequence descp (type (car (d)))

∨ set descp (type (car (d))) then marked (nil, typed (integer desc, vsize (value (car (d))))) else marked (size arg error,

default value (integer desc)) endif

else marked (arg err, default value (integer desc)) endif endlet

Definition: std upper (d) = let arg err be arg check (d, list ('type descriptor))

in if arg err = nil then let td be unmark (car (d))

in let r be tmax (td) in if r = nil then marked (unbounded type error (td),

default value (td))

elseif errorp (r) then marked (r, default value (td)) else marked (nil, typed (td, r)) endif endlet endlet else marked (arg err, default value (integer desc)) endif endlet

Definition: std succ (d) = let td be base type (type (car (d)))

in

let arg err be arg check (d, list (td))

in

if arg err = nil

then if scalar typep (td)

then if gtruep (gequal (car (d),

std upper (list (marked ('type descriptor,

td)))))

then marked (upper succ error (td),

default value (td))

else marked (nil,

typed (td, 1 + value (car (d)))) endif

else marked (succ arg error,

default value (integer desc)) endif else marked (arg err, default value (integer desc)) endif endlet endlet

; ***********
;  Variables
; ***********

Definition: new namep (n, v) = ((¬ in map (v, n)) ∧ (¬ reserved idp (n)))

Definition: free variablep (n, v) = in map (v, n)

Definition: free value (n, v) = mapped value (v, n)

Definition: apply var (fn, v, d) = if free variablep (fn, v) then select op (free value (fn, v), d)

else marked (unknown name error (fn), default value (integer desc)) endif

; ****************
;  Function Calls
; ****************

Definition: gf prec (u) = subst tree (mk entry value ('result),

mk identifier ('result), prec (u))

Definition: eq opp (op, etype) = if rule (op, prodn (tag ('binary operator, 'op), 'eq))

      ∨ rule (op, prodn (tag ('binary operator, 'op), 'equal))

then equality typep (etype)

elseif rule (op, prodn (tag ('binary operator, 'op), 'iff))

then boolean typep (etype)

else f endif

Definition: f of formals (fn, fs) = if fs ≃ nil

then mk expression (mk modified primary value (mk identifier (fn))) else mk expression (mk tree ('modified primary value,

list (mk modified primary value (mk identifier (fn)),

mk value modifiers (namelist to actuals (dparam name list (fs), nil))))) endif

Definition: function defn (u, ftype) = let fc be f of formals (unit name (u), formal dargs (u)),

result be mk expression ('result) in let e be postc (u, 'normal) in if rule (e,

          prodn (tag ('expression, 'e),
                list (tag ('expression, 'e1),
                   tag ('binary operator, 'op),
                   tag ('expression, 'e2))))

then if eq opp (subtree (e, 'binary operator), ftype)

then if (subtree i (e, 'expression, 1) = result) ∨ (subtree i (e, 'expression, 1)

= fc) then subst tree (fc,

result,

subtree i (e, 'expression, 2))

elseif (subtree i (e, 'expression, 2) = result)

∨ (subtree i (e, 'expression, 2)

= fc)

then subst tree (fc, result, subtree i (e, 'expression, 1))

else nil endif else nil endif else nil endif endlet endlet

; Previous definition of function_defn
;(defn function_defn (u ftype)
;  (let ((fc (f_of_formals (unit_name u) (formal_dargs u)))
; (result (mk_expression 'result)))
;  (let ((e (subst_tree result fc (postc u 'NORMAL))))
;
;    (if (rule e (prodn (tag 'expression 'e)
;        (list (tag 'expression 'e1)
;      (tag 'binary_operator 'op)
;      (tag 'expression 'e2))))
; (if (eq_opp (subtree e 'binary_operator) ftype)
;     (if (and (equal (subtree_i e 'expression 1) result)
;      (not (subtreep result (subtree_i e 'expression 2))))
; (subtree_i e 'expression 2)
;     (if (and (equal (subtree_i e 'expression 2) result)
;      (not (subtreep result (subtree_i e 'expression 1))))
; (subtree_i e 'expression 1)
;       nil))
;   nil)
;      nil))))

Definition: has defn (u, ftype) = if kind (u) = 'function then function defn (u, ftype) ≠ nil

elseif kind (u) = 'constant then constant value exp (u) ≠ nil else f endif

Definition: gdefn (u, ftype) = if kind (u) = 'function then function defn (u, ftype)

elseif kind (u) = 'constant then constant value exp (u)

else nil endif

Definition: formal type list (fs, sn, x) = if fs ≃ nil then nil

else cons (type desc (formal type (car (fs)), sn, nil, x), formal type list (cdr (fs), sn, x)) endif

Event: Disable reserved idp.

Event: Disable dparam name.

Event: Disable param reserved error.

Event: Disable dparam name list.

Event: Disable duplicate param names error.

Event: Disable access.

Event: Disable function access error.

Definition: fformals check (fs) = if fs ≃ nil then nil

elseif reserved idp (dparam name (car (fs)))

then param reserved error (car (fs))

elseif (dparam name (car (fs)) ∈ dparam name list (cdr (fs)))

∨ (dparam name (car (fs)) = 'result) then duplicate param names error (car (fs)) elseif access (car (fs)) = 'var then function access error (car (fs)) else fformals check (cdr (fs)) endif

Definition: farg check (fs, as, fsn, x) = let r be fformals check (fs)

in

if r = nil then arg check (as, formal type list (fs, fsn, x))

else r endif endlet

Definition: bind args (fs, as, fsn, x) = if fs ≃ nil then empty map

else add to map (bind args (rcdr (fs), rcdr (as), fsn, x), dparam name (rcar (fs)), marked (nil,

typed (type desc (formal type (rcar (fs)), fsn, nil, x), value (rcar (as))))) endif

Definition: mk entry name (n) = pack (rcons (unpack (n), ascii single quote))

Definition: type namep (tn, sn, x)

= ((tn ∈ '(boolean character integer rational))

∨ (kind (ref unit (ref (tn, sn, x))) = 'type))

Definition: type name expp (fn, ap, sn, x) = (type namep (fn, sn, x) ∧ (ap ≃ nil))

; ***********************
;  Expression Evaluation
; ***********************
; Note:  Semantic errors that don't come up during evaluation of expressions
;        are not detected.
;
;        1. Uniqueness of local names requirements are enforced only by the
;           reference resolution mechanism and by requiring unique names for
;           data objects in the environment.  For example, in
;
;               f(x) & all f : t, g(x,f)
;
;           the use of f both as a function name and as a bound identifier is
;           not detected, and in
;
;               function f (i : i) : boolean = pending
;
;           the use of i both as a parameter name and as a type name is not
;           detected.
;
;        2. Errors in conditional exit specifications of functions are
;           detected only if they make it impossible to locate the function
;           definition.  None of the errors in
;
;               function f (x : integer) : boolean =

;               begin
;                 exit case (is normal : (assume result = g(x));
;                   is     c1 : (assume c1(x));
;              is     c1 : (assume c2(x)));
;               end;
;
;           are detected.
;
;        3. Errors are detected in only the evaluated parts of if expressions.
;           For example, no errors are detected in
;
;               if false then
;                 'a'
;               elif true then
;                 3
;               elif 1/2 then
;                 [set: binary 28]
;               else 4 + "a string"
;               fi
;
;        4. Errors in scope, unit, and name declarations are detected only if
;           they come up in a unit reference.

Definition: bound values (e, c, x) = if rule (e,

          prodn (tag ('expression, 'e),
                list ('all, tag ('bound expression, 'b))))

then bound values (subtree (e, 'bound expression), c, x)

elseif rule (e,

             prodn (tag ('expression, 'e),
                   list ('some, tag ('bound expression, 'b))))

then bound values (subtree (e, 'bound expression), c, x)

elseif rule (e,

             prodn (tag ('bound expression, 'b),
                   list (tag ('identifier list, 'q),
                       'colon,
                       tag ('type specification, 's),
                       'comma,
                       tag ('expression, 'e))))

then marked typed value set (type desc (subtree (e,

                                             'type specification),

c, nil, x))

elseif rule (e,

             prodn (tag ('opt each clause, 'e),

list ('each,

                       tag ('identifier, 'i),
                       'colon,
                       tag ('type specification, 'ts),
                       'comma)))

then let td be type desc (subtree (e, 'type specification), c, nil, x)

in

if bounded index typep (td)

then marked typed value set (td)

else each id type error (e, c) endif endlet else nil endif

; =================================
;  Lemmas for GF Group Termination
; =================================
; Make these lemmas more reasonable if there is time.

; ==============================================
;  Case of Characters Does Not Affect Tree Size
; ==============================================

Theorem: upper case tree size ascii characterp (x) → (tree size (upper case (x)) = tree size (x))

Theorem: uc list tree size ascii character listp (x) → (tree size (uc list (x)) = tree size (x))

Event: Disable upper case tree size.

Event: Disable uc list tree size.

; ==========================================================

;  Else Part of If Expression Is Smaller than If Expression
; ==========================================================
; -------------------------
;  IF is smaller than ELIF
; -------------------------

Theorem: lessp subtrees imp lessp tree size (treep (x) ∧ treep (y) ∧ (tree size (subtrees (x)) < tree size (subtrees (y)))) → (tree size (x) < tree size (y))

Theorem: same leaf imp same tree size1 (leafp (x) ∧ leafp (y) ∧ (root (x) = root (y)) ∧ (lexeme (x) = lexeme (y))) → (tree size (x) = tree size (y))

Theorem: same leaf imp same tree size2 (leafp (x) ∧ leafp (y) ∧ (root (x) = root (y)) ∧ (uc list (lexeme (x)) = uc list (lexeme (y)))) → (tree size (x) = tree size (y))

Theorem: leaf equal imp tree size equal leaf equal (x, y) → (tree size (x) = tree size (y))

Theorem: tree equal imp tree size equal tree equal (x, y) → (tree size (x) = tree size (y))

Theorem: elif leafp (parse tree leafp (e) ∧ (root (e) = 'elif)) → tree equal (e, mk reserved word ('elif))

Theorem: mk rhs imp root (parse treep (e) ∧ (mk rhs (e) = 'elif)) → (parse tree leafp (e) ∧ (root (e) = 'elif))

Theorem: if exp else subtrees car rule (e,

     prodn (tag ('if expression else part, 'e),

list ('elif,

tag ('expression, 'b),
'then,
tag ('expression, 'p),
tag ('if expression else part, 'e2))))

→ tree equal (car (subtrees (e)), mk reserved word ('elif))

Theorem: lessp if than elif rule (e,

prodn (tag ('if expression else part, 'e),

list ('elif,

tag ('expression, 'b),
'then,
tag ('expression, 'p),
tag ('if expression else part, 'e2))))

→ (tree size (mk reserved word ('if)) < tree size (car (subtrees (e))))

; ---------------------
;  Subtrees Are a List
; ---------------------

Theorem: listp if exp else subtrees rule (e,

prodn (tag ('if expression else part, 'e),

list ('elif,

tag ('expression, 'b),
'then,
tag ('expression, 'p),
tag ('if expression else part, 'e2))))

→ listp (subtrees (e))

; --------------------------
;  The Else Part Is Smaller
; --------------------------

Theorem: lessp car imp lessp tree size (listp (x) ∧ listp (y) ∧ (tree size (car (x)) < tree size (car (y))) ∧ (tree size (cdr (x)) = tree size (cdr (y)))) → (tree size (x) < tree size (y))

Theorem: lessp mk tree car imp lessp tree size (treep (e) ∧ listp (subtrees (e)) ∧ (tree size (k) < tree size (car (subtrees (e))))) → (tree size (mk tree (nt, cons (k, cdr (subtrees (e))))) < tree size (e))

Event: Disable lessp car imp lessp tree size.

Theorem: leq if exp else part (tree size (if else exp (e)) ≮ tree size (e)) → (tree size (if else exp (e)) = tree size (e))

Theorem: lessp if exp else part rule (e, prodn (x, y)) → (tree size (if else exp (subtree (e, n))) < tree size (e))

; =======================================
;  Gname Is Smaller Than Identifier Tree
; =======================================

Theorem: identifierp imp treep identifierp (e) → treep (e)

Theorem: lessp gname tree size 0 treep (e) → (tree size (gname (e)) < tree size (e))

Theorem: lessp gname tree size identifierp (e) → (tree size (gname (e)) < tree size (e))

; ===================================================
;  Object Name Is Smaller Than Containing Expression
; ===================================================

Theorem: leq object name tree size (tree size (object name (e)) ≮ tree size (e)) → (tree size (object name (e)) = tree size (e))

Event: Disable leq object name tree size.

Theorem: lessp object name tree size rule (e, prodn (x, y)) → (tree size (object name (subtree (e, n))) < tree size (e))

; ==================================================
;  Argument List Smaller Than Containing Expression
; ==================================================

Theorem: leq arg list tree size (tree size (arg list (e)) ≮ tree size (e)) → (tree size (arg list (e)) = tree size (e))

Event: Disable leq arg list tree size.

Theorem: lessp arg list tree size rule (e, prodn (x, y)) → (tree size (arg list (subtree (e, n))) < tree size (e))

; ========================================================
;  Bound Identifier Is Smaller Than Containing Expression
; ========================================================

Theorem: leq bound id tree size (tree size (bound id (e)) ≮ tree size (e)) → (tree size (bound id (e)) = tree size (e))

Event: Disable leq bound id tree size.

Theorem: lessp bound id tree size rule (e, prodn (x, y)) → (tree size (bound id (subtree (e, n))) < tree size (e))

Event: Disable *1*gfalse.

Event: Disable *1*gizero.

Event: Disable *1*gtrue.

Event: Disable *1*boolean desc.

Event: Disable *1*integer desc.

Event: Disable *1*mk unary operator.

Event: Disable gf prec.

Event: Disable gand. Event: Disable gchar. Event: Disable gdefn. Event: Disable gfalse. Event: Disable gizero. Event: Disable gle. Event: Disable gmap insert. Event: Disable gmapomit. Event: Disable gor. Event: Disable grange elements. Event: Disable gseq insert before. Event: Disable gseq insert behind. Event: Disable gseqomit. Event: Disable gset or seq. Event: Disable gstring seq. Event: Disable gtrue. Event: Disable gtruep. Event: Disable arg list.

Event: Disable add to map. Event: Disable apply binary op. Event: Disable apply unary op. Event: Disable apply var. Event: Disable bad value modifiers error. Event: Disable base type. Event: Disable bind args. Event: Disable boolean desc. Event: Disable bound id. Event: Disable bound values. Event: Disable cdr quantified exp. Event: Disable character valuep. Event: Disable condition params error. Event: Disable default value. Event: Disable determinate. Event: Disable digit listp. Event: Disable each clausep. Event: Disable entry name.

Event: Disable entry not true error. Event: Disable entry valuep. Event: Disable errorp. Event: Disable farg check. Event: Disable fn call formp. Event: Disable formal dargs. Event: Disable free variablep. Event: Disable gname. Event: Disable has defn. Event: Disable identifierp. Event: Disable if else exp. Event: Disable in type. Event: Disable indeterminate. Event: Disable indeterminate fn result error. Event: Disable integer desc. Event: Disable kind. Event: Disable length. Event: Disable minteger.

Event: Disable mk entry name. Event: Disable mk identifier. Event: Disable mk unary operator. Event: Disable n too small. Event: Disable name already in use error. Event: Disable new namep. Event: Disable no function defn error. Event: Disable not expression error. Event: Disable not function or const error. Event: Disable object name. Event: Disable put op. Event: Disable rcar. Event: Disable rcdr. Event: Disable rcons. Event: Disable record get. Event: Disable ref. Event: Disable result type. Event: Disable select op.

Event: Disable std domain. Event: Disable std first. Event: Disable std initial. Event: Disable std last. Event: Disable std lower. Event: Disable std max. Event: Disable std min. Event: Disable std nonfirst. Event: Disable std nonlast. Event: Disable std null. Event: Disable std ord. Event: Disable std pred. Event: Disable std range. Event: Disable std scale. Event: Disable std size. Event: Disable std succ. Event: Disable std upper. Event: Disable string valuep.

Event: Disable subsequence get.

Event: Disable tree size.

Event: Disable type.

Event: Disable type desc.

Event: Disable type name expp.

Event: Disable typed.

Event: Disable unmark.

Event: Disable value.

#|
(do-mutual '(

; ***************************
;  Set/Sequence Constructors
; ***************************
(defn GF_element_list (e c v n x)
  (if (rule e (prodn (tag 'range 'r)
     (list 'OPEN_PAREN (tag 'range_limits 'r2) 'CLOSE_PAREN)))
      (GF_element_list (subtree e 'range_limits) c v n x)
  (if (rule e (prodn (tag 'element_list 'e)
     (tag 'value_list 'v)))
      (GF_element_list (subtree e 'value_list) c v n x)
  (if (rule e (prodn (tag 'element_list 'e)
     (tag 'range_limits 'r)))
      (GF_element_list (subtree e 'range_limits) c v n x)
  (if (rule e (prodn (tag 'range_limits 'r)
     (list (tag 'expression 'lo) 'DOT_DOT

(tag 'expression 'hi))))
 (Grange_elements (GF (subtree_i e 'expression 1) c v n x)
  (GF (subtree_i e 'expression 2) c v n x))
(if (rule e (prodn (tag 'value_list 'v)
(tag 'expression 'e)))
 (rcons nil (GF (subtree e 'expression) c v n x))
(if (rule e (prodn (tag 'value_list 'v)
(list (tag 'value_list 'v2) 'COMMA
(tag 'expression 'e))))
 (rcons (GF_element_list (subtree e 'value_list) c v n x)
(GF (subtree e 'expression) c v n x))
nil))))))
( (ord-lessp (cons (cons (add1 n)
(add1 (tree_size e)))
(count c))) )) ; (count c) is a place filler
(defn GF_element_type (e c v n x)
(if (rule e (prodn (tag 'range 'r)
(list 'OPEN_PAREN (tag 'range_limits 'r2) 'CLOSE_PAREN)))
 (GF_element_type (subtree e 'range_limits) c v n x)
(if (rule e (prodn (tag 'element_list 'e)
(tag 'value_list 'v)))
 (GF_element_type (subtree e 'value_list) c v n x)
(if (rule e (prodn (tag 'element_list 'e)
(tag 'range_limits 'r)))
 (GF_element_type (subtree e 'range_limits) c v n x)
(if (rule e (prodn (tag 'range_limits 'r)
(list (tag 'expression 'lo) 'DOT_DOT
(tag 'expression 'hi))))
 (base_type (type (GF (subtree_i e 'expression 1) c v n x)))
(if (rule e (prodn (tag 'value_list 'v)
(tag 'expression 'e)))
 (base_type (type (GF (subtree e 'expression) c v n x)))
(if (rule e (prodn (tag 'value_list 'v)
(list (tag 'value_list 'v2) 'COMMA

 (tag 'expression 'e))))
    (GF_element_type (subtree e 'value_list) c v n x)
  nil))))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size e)))
   (count c))) )) ; (count c) is a place filler

; ************************
;  Quantified expressions
; ************************
(defn GF_all (id vs e c v n x)
(if (nlistp vs)
    (Gtrue)
(if (new_namep id v)
    (if (zerop n)
(marked (n_too_small)
(default_value (boolean_desc)))
      (Gand (GF_all id (rcdr vs) e c v n x)
    (GF e c (add_to_map v id (rcar vs)) (sub1 n) x)))
  (marked (name_already_in_use_error id)
  (default_value (boolean_desc)))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size id)))
   (count vs))) ))
(defn GF_some (id vs e c v n x)
(if (nlistp vs)
    (Gfalse)
  (if (new_namep id v)
    (if (zerop n)
(marked (n_too_small)
(default_value (boolean_desc)))
(Gor (GF_some id (rcdr vs) e c v n x)
   (GF e c (add_to_map v id (rcar vs)) (sub1 n) x)))
    (marked (name_already_in_use_error id)
    (default_value (boolean_desc)))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size id)))
   (count vs))) ))

; *********************
;  Value Modifications
; *********************
(defn GF_each (id vs bv e c v n x)
; e is the <component modification>
(if (nlistp vs)
    bv
(if (new_namep id v)
    (if (zerop n)
(marked (n_too_small)
(default_value (base_type (type bv))))
(GF_each id (cdr vs)
(GF_modifiers bv e c (add_to_map v id (car vs)) (sub1 n) x)
e c v n x))
  (marked (name_already_in_use_error id)
  (default_value (base_type (type bv))))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size e)))
   (count vs))) ))
(defn GF_adp (e c v n x)
(if (rule e (prodn (tag 'arg_list 'as)
   (list 'OPEN_PAREN (tag 'value_list 'vs)
 'CLOSE_PAREN)))
    (GF_adp (subtree e 'value_list) c v n x)
(if (rule e (prodn (tag 'value_list 'vs)
   (tag 'expression 'e)))
    (rcons nil (GF (subtree e 'expression) c v n x))
(if (rule e (prodn (tag 'value_list 'vs)
   (list (tag 'value_list 'vs2)
 'COMMA (tag 'expression 'e))))
    (rcons (GF_adp (subtree e 'value_list) c v n x)
   (GF (subtree e 'expression) c v n x))
  nil)))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size e)))
   (count c))) )) ; (count c) is a place filler

(defn GF_selectors (e c v n x)
(if (rule e (prodn (tag 'selector_list 's)
   (tag 'component_selectors 's2)))
    (GF_selectors (subtree e 'component_selectors) c v n x)
(if (rule e (prodn (tag 'selector_list 's)
   (list (tag 'selector_list 's2)
 (tag 'component_selectors 's3))))
    (append (GF_selectors (subtree e 'selector_list) c v n x)
    (GF_selectors (subtree e 'component_selectors) c v n x))
(if (rule e (prodn (tag 'component_selectors 's)
   (list 'DOT (tag 'IDENTIFIER 'fn))))
    (list (marked 'field_name
  (gname (subtree e 'IDENTIFIER))))
(if (rule e (prodn (tag 'component_selectors 's)
   (tag 'arg_list 'd)))
    (GF_adp (subtree e 'arg_list) c v n x)
(if (rule e (prodn (tag 'arg_list 'as)
   (list 'OPEN_PAREN (tag 'value_list 'vs)
 'CLOSE_PAREN)))
    (GF_adp (subtree e 'value_list) c v n x)
  nil)))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size e)))
   (count c))) )) ; (count c) is a place filler
(defn GF_modifiers (bv e c v n x)
; e is the <value modifiers>
(if (rule e (prodn (tag 'value_modifiers 'm)
   (tag 'component_selectors 's)))
    (GF_modifiers bv (subtree e 'component_selectors) c v n x)
(if (rule e (prodn (tag 'component_selectors 's)
   (list 'DOT (tag 'IDENTIFIER 'fn))))
    (record_get bv
(marked 'field_name
(gname (subtree e 'IDENTIFIER)))

(type bv))
(if (rule e (prodn (tag 'component_selectors 's)
   (tag 'arg_list 'd)))
    (select_op bv (GF_adp (subtree e 'arg_list) c v n x))
(if (rule e (prodn (tag 'value_modifiers 'm)
   (tag 'range 'r)))
    (GF_modifiers bv (subtree e 'range) c v n x)
(if (rule e (prodn (tag 'range 'r)
   (list 'OPEN_PAREN (tag 'range_limits 'r2)
 'CLOSE_PAREN)))
    (GF_modifiers bv (subtree e 'range_limits) c v n x)
(if (rule e (prodn (tag 'range_limits 'r)
   (list (tag 'expression 'lo) 'DOT_DOT
 (tag 'expression 'hi))))
    (subsequence_get bv
     (GF (subtree_i e 'expression 1) c v n x)
     (GF (subtree_i e 'expression 2) c v n x))
(if (rule e (prodn (tag 'value_modifiers 'm)
   (tag 'value_alterations 'a)))
    (GF_modifiers bv (subtree e 'value_alterations) c v n x)
(if (rule e (prodn (tag 'value_alterations 'a)
   (list 'WITH 'OPEN_PAREN
 (tag 'component_alterations_list 'al)
 'CLOSE_PAREN)))
    (GF_modifiers bv (subtree e 'component_alterations_list) c v n x)
(if (rule e (prodn (tag 'component_alterations_list 'al)
   (tag 'component_alterations 'a)))
    (GF_modifiers bv (subtree e 'component_alterations) c v n x)
(if (rule e (prodn (tag 'component_alterations_list 'al)
   (list (tag 'component_alterations_list 'al2)
 'SEMI_COLON (tag 'component_alterations 'a))))
    (GF_modifiers (GF_modifiers bv (subtree e 'component_alterations_list)
c v n x)
  (subtree e 'component_alterations) c v n x)
(if (rule e (prodn (tag 'component_alterations 'as)

(list (tag 'opt_each_clause 'e)
(tag 'component_assignment 'a))))
(if (each_clausep (subtree e 'opt_each_clause))
(let ((vs (bound_values (subtree e 'opt_each_clause) c x)))
(if (errorp vs)
(marked vs (default_value (base_type (type bv))))
(GF_each (bound_id (subtree e 'opt_each_clause))
 vs bv (subtree e 'component_assignment) c v n x)))
(GF_modifiers bv (subtree e 'component_assignment) c v n x))
(if (rule e (prodn (tag 'component_alterations 'as)
(list (tag 'opt_each_clause 'e)
(tag 'component_creation 'c))))
(if (each_clausep (subtree e 'opt_each_clause))
(let ((vs (bound_values (subtree e 'opt_each_clause) c x)))
(if (errorp vs)
(marked vs (default_value (base_type (type bv))))
(GF_each (bound_id (subtree e 'opt_each_clause))
 vs bv (subtree e 'component_creation) c v n x)))
(GF_modifiers bv (subtree e 'component_creation) c v n x))
(if (rule e (prodn (tag 'component_alterations 'as)
(list (tag 'opt_each_clause 'e)
(tag 'component_deletion 'd))))
(if (each_clausep (subtree e 'opt_each_clause))
(let ((vs (bound_values (subtree e 'opt_each_clause) c x)))
(if (errorp vs)
(marked vs (default_value (base_type (type bv))))
(GF_each (bound_id (subtree e 'opt_each_clause))
 vs bv (subtree e 'component_deletion) c v n x)))
(GF_modifiers bv (subtree e 'component_deletion) c v n x))
(if (rule e (prodn (tag 'component_assignment 'a)
(list (tag 'selector_list 's)
'COLON_EQUAL (tag 'expression 'e))))
(put_op bv
(GF_selectors (subtree e 'selector_list) c v n x)
(GF (subtree e 'expression) c v n x))
(if (rule e (prodn (tag 'component_creation 'c)
(list 'BEFORE (tag 'selector_list 's)
'COLON_EQUAL (tag 'expression 'e))))
(let ((s (GF_selectors (subtree e 'selector_list) c v n x))
(u (GF (subtree e 'expression) c v n x)))

(put_op bv (rcdr s)
(Gseq_insert_before (select_op bv (rcdr s)) (rcar s) u)))
  (if (rule e (prodn (tag 'component_creation 'c)
     (list 'BEHIND (tag 'selector_list 's)
   'COLON_EQUAL (tag 'expression 'e))))
      (let ((s (GF_selectors (subtree e 'selector_list) c v n x))
    (u (GF (subtree e 'expression) c v n x)))
(put_op bv (rcdr s)
(Gseq_insert_behind (select_op bv (rcdr s)) (rcar s) u)))
  (if (rule e (prodn (tag 'component_creation 'c)
     (list 'INTO (tag 'selector_list 's)
   'COLON_EQUAL (tag 'expression 'e))))
      (let ((s (GF_selectors (subtree e 'selector_list) c v n x))
    (u (GF (subtree e 'expression) c v n x)))
(put_op bv (rcdr s)
(Gmap_insert (select_op bv (rcdr s)) (rcar s) u)))
  (if (rule e (prodn (tag 'component_deletion 'd)
     (list 'SEQOMIT (tag 'selector_list 's))))
      (let ((s (GF_selectors (subtree e 'selector_list) c v n x)))
(put_op bv (rcdr s)
(Gseqomit (select_op bv (rcdr s)) (rcar s))))
  (if (rule e (prodn (tag 'component_deletion 'd)
     (list 'MAPOMIT (tag 'selector_list 's))))
      (let ((s (GF_selectors (subtree e 'selector_list) c v n x)))
(put_op bv (rcdr s)
(Gmapomit (select_op bv (rcdr s)) (rcar s))))
    (marked (bad_value_modifiers_error e)
    (default_value (base_type (type bv)))))))))))))))))))))))
  ( (ord-lessp (cons (cons (add1 n)
   (add1 (tree_size e)))
     (count c))) )) ; (count c) is a place filler

; ************************************
;  Name references and function calls
; ************************************

(defn apply_fun (fn d sn n x)
  (let ((h (car (ref fn sn x)))  ; scope fn is declared in
(u (cdr (ref fn sn x)))) ; the function declaration
    (if (or (equal (kind u) 'function)
    (equal (kind u) 'constant))
(let ((ftype (type_desc (result_type u) h nil x))
      (fs (formal_dargs u)))                  ; formals
(let ((a (if (equal (length fs) 0) nil d))    ; actuals
      (s (if (equal (length fs) 0) d nil)))   ; selectors
  (if (zerop (fix n))
      (marked (n_too_small)
      (default_value ftype))
    (select_op
     (let ((arg_err (farg_check fs a h x)))
       (if (equal arg_err nil)
   (let ((v (add_to_map (bind_args fs a h x)
(mk_entry_name 'result)
(std_initial
 (list (marked 'type_descriptor
       ftype))))))
     (if (Gtruep (GF (GF_prec u) h v (sub1 n) x))
 (if (has_defn u ftype)
     (let ((r (GF (Gdefn u ftype)
  h v (sub1 n) x)))
       (if (and (determinate r)
(truep (in_type ftype r)))
   (marked nil
   (typed ftype (value r)))
 (marked
   (indeterminate_fn_result_error fn sn)
   (default_value ftype))))
   (marked (no_function_defn_error fn sn)
   (default_value ftype)))
       (marked (entry_not_true_error fn sn)
       (default_value ftype))))
 (marked arg_err (default_value ftype))))
     s))))
    (if (equal (kind u) 'error)
(marked u (default_value (integer_desc)))
      (marked (not_function_or_const_error fn sn)
      (default_value (integer_desc))))))
  ( (ord-lessp (cons (cons (add1 n)
   (add1 (tree_size fn)))
     (tree_size fn))) ))

(defn Gapply (fn ap sn v n x)
(if (free_variablep fn v)
    (apply_var fn v ap)
(if (equal fn 'false)
    (select_op (Gfalse) ap)
(if (equal fn 'true)
    (select_op (Gtrue) ap)
(if (type_name_expp fn ap sn x)
    (marked 'type_descriptor
    (type_desc (mk_identifier fn) sn nil x))
(if (equal fn 'domain)
    (std_domain ap)
(if (equal fn 'first)
    (std_first ap)
(if (equal fn 'initial)
    (std_initial ap)
(if (equal fn 'last)
    (std_last ap)
(if (equal fn 'lower)
    (std_lower ap)
(if (equal fn 'max)
    (std_max ap)
(if (equal fn 'min)
    (std_min ap)
(if (equal fn 'nonfirst)
    (std_nonfirst ap)
(if (equal fn 'nonlast)
    (std_nonlast ap)
(if (equal fn 'null)
    (std_null ap)
(if (equal fn 'ord)
    (std_ord ap)
(if (equal fn 'pred)
    (std_pred ap)
(if (equal fn 'range)
    (std_range ap)
(if (equal fn 'scale)
    (std_scale ap)
(if (equal fn 'size)
    (std_size ap)
(if (equal fn 'succ)
    (std_succ ap)
(if (equal fn 'upper)

    (std_upper ap)
  (apply_fun fn ap sn n x))))))))))))))))))))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size fn)))
   (add1 (tree_size fn)))) ))

(defn GF (e c v n x)
; The meta-function GF(e,c,v,n,x) gives the value that results when the
; expression e is evaluated, in the context of scope c with free variables
; bound as determined in the environment v, by at most n applications of
; functions described by the Gypsy sentence x.
;
; The domain and range of GF(e,c,v,n,x) are as follows:
;
;   e is the parse tree representing the expression to be evaluated.
;   c is the (litatom) name of the Gypsy scope in which e is evaluated.
;   v is the name-value mapping that maps names of free variables
;     into their (marked typed) values.
;   n is the maximum allowed depth of Gypsy function calls and quantifiers
;   x is the parse tree representing the Gypsy sentence that is being
;     interpreted.  This is the complete sentence containing the list of all
;     available scopes.
;   GF(e,c,v,n,x) is the marked, typed value that results from evaluating e.
;

; ************************
;
;    <expression> ::= ...
;
; ************************
(if (rule e (prodn (tag 'expression 'e)
   (tag 'modified_primary_value 'm)))
    (GF (subtree e 'modified_primary_value) c v n x)
(if (rule e (prodn (tag 'expression 'e)
   (list 'ALL (tag 'bound_expression 'b))))
    (let ((vs (bound_values e c x)))
(if (errorp vs)
  (marked vs (default_value (boolean_desc)))
(GF_all (bound_id (subtree e 'bound_expression))

vs (cdr_quantified_exp e) c v n x)))
(if (rule e (prodn (tag 'expression 'e)
   (list 'SOME (tag 'bound_expression 'b))))
    (let ((vs (bound_values e c x)))
(if (errorp vs)
  (marked vs (default_value (boolean_desc)))
(GF_some (bound_id (subtree e 'bound_expression))
 vs (cdr_quantified_exp e) c v n x)))
(if (rule e (prodn (tag 'expression 'e)
   (list (tag 'unary_operator 'op) (tag 'expression 'e2))))
    (apply_unary_op (subtree e 'unary_operator)
    (GF (subtree e 'expression) c v n x))
(if (rule e (prodn (tag 'expression 'e)
   (list (tag 'expression 'e1) (tag 'binary_operator 'op)
 (tag 'expression 'e2))))
    (apply_binary_op (subtree e 'binary_operator)
     (GF (subtree_i e 'expression 1) c v n x)
     (GF (subtree_i e 'expression 2) c v n x))

; ********************************
;
;    <modified primary value> ::=
;
; ********************************
(if (rule e (prodn (tag 'modified_primary_value 'm)
   (tag 'primary_value 'p)))
    (GF (subtree e 'primary_value) c v n x)
(if (rule e (prodn (tag 'modified_primary_value 'm)
   (list (tag 'modified_primary_value 'm2)
 (tag 'value_modifiers 'vm))))
    (if (fn_call_formp e)
(Gapply (object_name (subtree e 'modified_primary_value))
(GF_adp (arg_list (subtree e 'value_modifiers))
c v n x)
c v n x)
(GF_modifiers (GF (subtree e 'modified_primary_value) c v n x)
    (subtree e 'value_modifiers) c v n x))

(if (rule e (prodn (tag 'modified_primary_value 'm)
   (list (tag 'modified_primary_value 'm2)
 (tag 'actual_condition_parameters 'cp))))
    ; Condition parameters allowed only in <specification expression>
    ; with validation directive (p. 35, Gypsy 2.05 Report).
    ; **** Weed them out before calling GF in that case. ****
    (let ((r (GF (subtree e 'modified_primary_value) c v n x)))
(marked (condition_params_error e)
(default_value (type r))))

; ***********************
;
;    <primary value> ::=
;
; ***********************
(if (rule e (prodn (tag 'primary_value 'p)
   (tag 'literal_value 'l)))
    (GF (subtree e 'literal_value) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)
   (tag 'set_or_sequence_value 's)))
    (GF (subtree e 'set_or_sequence_value) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)
   (tag 'ENTRY_VALUE 'e)))
    (GF (subtree e 'ENTRY_VALUE) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)
   (tag 'IDENTIFIER 'on)))
    (GF (subtree e 'IDENTIFIER) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)
   (tag 'if_expression 'i)))
    (GF (subtree e 'if_expression) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)
   (list 'OPEN_PAREN (tag 'expression 'e) 'CLOSE_PAREN)))
    (GF (subtree e 'expression) c v n x)

; --------------------------------------------------------------------------
;

;  From here down to parse tree leaves, clauses are in alphabetical order
;  by the left-hand side of the productions.  Everything that is a parse
;  tree for an expression should be covered.
;
; --------------------------------------------------------------------------

; ***********************
;
;    <constant body> ::=
;
; ***********************
; I don't think the following needs to be here.  siebert 9/Sept/90
(if (rule e (prodn (tag 'constant_body 'b)
   (tag 'expression 'e)))
    (GF (subtree e 'expression) c v n x)

; ***********************
;
;    <if expression> ::=
;
; ***********************
(if (rule e (prodn (tag 'if_expression 'i)
   (list 'IF (tag 'expression 'b) 'THEN
 (tag 'expression 'p)
 (tag 'if_expression_else_part 'e))))
    ; Note:  this does not require all potential value expressions to be the
    ; same type or all boolean expressions to be boolean.
    (let ((bv (GF (subtree_i e 'expression 1) c v n x)))
(if (indeterminate bv)
  (marked (mark bv)
  (default_value
    (type (GF (subtree_i e 'expression 2)
c v n x))))
      (if (truep (in_type (boolean_desc) bv))
  (if (Gtruep bv)
(GF (subtree_i e 'expression 2) c v n x)
    (GF (if_else_exp (subtree e 'if_expression_else_part))
c v n x))
(marked (if_test_not_boolean_error e c)

(default_value
  (type (GF (subtree_i e 'expression 2)
    c v n x)))))))

; ***********************
;
;    <literal value> ::=
;
; ***********************
(if (rule e (prodn (tag 'literal_value 'l)
   (tag 'CHARACTER_VALUE 'ch)))
    (GF (subtree e 'CHARACTER_VALUE) c v n x)
(if (rule e (prodn (tag 'literal_value 'l)
   (tag 'number 'n)))
    (GF (subtree e 'number) c v n x)
(if (rule e (prodn (tag 'literal_value 'l)
   (tag 'STRING_VALUE 's)))
    (GF (subtree e 'STRING_VALUE) c v n x)

; ****************
;
;    <number> ::=
;
; ****************
(if (rule e (prodn (tag 'number 'n)
   (tag 'DIGIT_LIST 's)))
    (minteger e)
(if (rule e (prodn (tag 'number 'n)
   (list (tag 'base 'b) (tag 'DIGIT_LIST 's))))
    (minteger e)

; *****************************************
;
;    <pre-computable label expression> ::=
;
; *****************************************

(if (rule e (prodn (tag 'pre_computable_label_expression 'p)
   (tag 'number 'n)))
    (GF (subtree e 'number) c v n x)
(if (rule e (prodn (tag 'pre_computable_label_expression 'p)
   (list 'MINUS (tag 'number 'n))))
    (apply_unary_op (mk_unary_operator 'MINUS)
    (GF (subtree e 'number) c v n x))
(if (rule e (prodn (tag 'pre_computable_label_expression 'p)
   (tag 'CHARACTER_VALUE 'ch)))
    (GF (subtree e 'CHARACTER_VALUE) c v n x)
(if (rule e (prodn (tag 'pre_computable_label_expression 'p)
   (tag 'IDENTIFIER 'i)))
    (GF (subtree e 'IDENTIFIER) c v n x)

; ********************************
;
;    <set or sequence value> ::=
;
; ********************************
(if (rule e (prodn (tag 'set_or_sequence_value 's)
   (list 'OPEN_PAREN (tag 'set_or_seq_mark 'm)
 (tag 'element_list 'e) 'CLOSE_PAREN)))
    (Gset_or_seq (subtree e 'set_or_seq_mark)
 (GF_element_list (subtree e 'element_list) c v n x)
 (GF_element_type (subtree e 'element_list) c v n x))
(if (rule e (prodn (tag 'set_or_sequence_value 's)
   (tag 'range 'r)))
    (Gset_or_seq nil
 (GF_element_list (subtree e 'range) c v n x)
 (GF_element_type (subtree e 'range) c v n x))

; *********************
;
;    PARSE TREE LEAVES
;
; *********************

  (if (character_valuep e)
      (Gchar e)
  (if (digit_listp e)
      (minteger e)
  (if (entry_valuep e)
      (apply_var (entry_name e) v nil)
  (if (identifierp e)
      (Gapply (gname e) nil c v n x)
  (if (string_valuep e)
      (Gstring_seq e)
    (marked (not_expression_error e) (default_value (integer_desc)))
    ))))))))))))))))))))))))))))))))
  ( (ord-lessp (cons (cons (add1 n)
   (add1 (tree_size e)))
     (count c))) )) ; (count c) is a place filler
))
|#

#|
(do-mutual '(

; ***************************
;  Set/Sequence Constructors
; ***************************
(defn GF_element_list (e c v n x)
  (if (rule e (prodn (tag 'range 'r)
     (list 'OPEN_PAREN (tag 'range_limits 'r2) 'CLOSE_PAREN)))
      (GF_element_list (subtree e 'range_limits) c v n x)

(if (rule e (prodn (tag 'element_list 'e)
   (tag 'value_list 'v)))
    (GF_element_list (subtree e 'value_list) c v n x)
(if (rule e (prodn (tag 'element_list 'e)
   (tag 'range_limits 'r)))
    (GF_element_list (subtree e 'range_limits) c v n x)
(if (rule e (prodn (tag 'range_limits 'r)
   (list (tag 'expression 'lo) 'DOT_DOT
 (tag 'expression 'hi))))
    (Grange_elements (GF (subtree_i e 'expression 1) c v n x)
     (GF (subtree_i e 'expression 2) c v n x))
(if (rule e (prodn (tag 'value_list 'v)
   (tag 'expression 'e)))
    (rcons nil (GF (subtree e 'expression) c v n x))
(if (rule e (prodn (tag 'value_list 'v)
   (list (tag 'value_list 'v2) 'COMMA
 (tag 'expression 'e))))
    (rcons (GF_element_list (subtree e 'value_list) c v n x)
   (GF (subtree e 'expression) c v n x))
  nil))))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size e)))
   (count c))) )) ; (count c) is a place filler
(defn GF_element_type (e c v n x)
(if (rule e (prodn (tag 'range 'r)
   (list 'OPEN_PAREN (tag 'range_limits 'r2) 'CLOSE_PAREN)))
    (GF_element_type (subtree e 'range_limits) c v n x)
(if (rule e (prodn (tag 'element_list 'e)
   (tag 'value_list 'v)))
    (GF_element_type (subtree e 'value_list) c v n x)
(if (rule e (prodn (tag 'element_list 'e)
   (tag 'range_limits 'r)))
    (GF_element_type (subtree e 'range_limits) c v n x)
(if (rule e (prodn (tag 'range_limits 'r)

   (list (tag 'expression 'lo) 'DOT_DOT
 (tag 'expression 'hi))))
    (base_type (type (GF (subtree_i e 'expression 1) c v n x)))
(if (rule e (prodn (tag 'value_list 'v)
   (tag 'expression 'e)))
    (base_type (type (GF (subtree e 'expression) c v n x)))
(if (rule e (prodn (tag 'value_list 'v)
   (list (tag 'value_list 'v2) 'COMMA
 (tag 'expression 'e))))
    (GF_element_type (subtree e 'value_list) c v n x)
  nil))))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size e)))
   (count c))) )) ; (count c) is a place filler

; ************************
;  Quantified expressions
; ************************
(defn GF_all (id vs e c v n x)
(if (nlistp vs)
    (Gtrue)
(if (new_namep id v)
    (if (zerop n)
(marked (n_too_small)
(default_value (boolean_desc)))
      (Gand (GF_all id (rcdr vs) e c v n x)
    (GF e c (add_to_map v id (rcar vs)) (sub1 n) x)))
  (marked (name_already_in_use_error id)
  (default_value (boolean_desc)))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size id)))
   (count vs))) ))
(defn GF_some (id vs e c v n x)
(if (nlistp vs)
    (Gfalse)
  (if (new_namep id v)
    (if (zerop n)

(marked (n_too_small)
(default_value (boolean_desc)))
(Gor (GF_some id (rcdr vs) e c v n x)
   (GF e c (add_to_map v id (rcar vs)) (sub1 n) x)))
    (marked (name_already_in_use_error id)
    (default_value (boolean_desc)))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size id)))
   (count vs))) ))

; *********************
;  Value Modifications
; *********************
(defn GF_each (id vs bv e c v n x)
; e is the <component modification>
(if (nlistp vs)
    bv
(if (new_namep id v)
    (if (zerop n)
(marked (n_too_small)
(default_value (base_type (type bv))))
(GF_each id (cdr vs)
(GF_modifiers bv e c (add_to_map v id (car vs)) (sub1 n) x)
e c v n x))
  (marked (name_already_in_use_error id)
  (default_value (base_type (type bv))))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size e)))
   (count vs))) ))
(defn GF_adp (e c v n x)
(if (rule e (prodn (tag 'arg_list 'as)
   (list 'OPEN_PAREN (tag 'value_list 'vs)
 'CLOSE_PAREN)))
    (GF_adp (subtree e 'value_list) c v n x)
(if (rule e (prodn (tag 'value_list 'vs)
   (tag 'expression 'e)))
    (rcons nil (GF (subtree e 'expression) c v n x))
(if (rule e (prodn (tag 'value_list 'vs)

(list (tag 'value_list 'vs2)
'COMMA (tag 'expression 'e))))
 (rcons (GF_adp (subtree e 'value_list) c v n x)
(GF (subtree e 'expression) c v n x))
nil)))
( (ord-lessp (cons (cons (add1 n)
(add1 (tree_size e)))
(count c))) )) ; (count c) is a place filler
(defn GF_selectors (e c v n x)
(if (rule e (prodn (tag 'selector_list 's)
(tag 'component_selectors 's2)))
 (GF_selectors (subtree e 'component_selectors) c v n x)
(if (rule e (prodn (tag 'selector_list 's)
(list (tag 'selector_list 's2)
(tag 'component_selectors 's3))))
 (append (GF_selectors (subtree e 'selector_list) c v n x)
 (GF_selectors (subtree e 'component_selectors) c v n x))
(if (rule e (prodn (tag 'component_selectors 's)
(list 'DOT (tag 'IDENTIFIER 'fn))))
 (list (marked 'field_name
(gname (subtree e 'IDENTIFIER))))
(if (rule e (prodn (tag 'component_selectors 's)
(tag 'arg_list 'd)))
 (GF_adp (subtree e 'arg_list) c v n x)
(if (rule e (prodn (tag 'arg_list 'as)
(list 'OPEN_PAREN (tag 'value_list 'vs)
'CLOSE_PAREN)))
 (GF_adp (subtree e 'value_list) c v n x)
nil)))))
( (ord-lessp (cons (cons (add1 n)
(add1 (tree_size e)))
(count c))) )) ; (count c) is a place filler
(defn GF_modifiers (bv e c v n x)
; e is the <value modifiers>

(if (rule e (prodn (tag 'value_modifiers 'm)
   (tag 'component_selectors 's)))
    (GF_modifiers bv (subtree e 'component_selectors) c v n x)
(if (rule e (prodn (tag 'component_selectors 's)
   (list 'DOT (tag 'IDENTIFIER 'fn))))
    (record_get bv
(marked 'field_name
(gname (subtree e 'IDENTIFIER)))
(type bv))
(if (rule e (prodn (tag 'component_selectors 's)
   (tag 'arg_list 'd)))
    (select_op bv (GF_adp (subtree e 'arg_list) c v n x))
(if (rule e (prodn (tag 'value_modifiers 'm)
   (tag 'range 'r)))
    (GF_modifiers bv (subtree e 'range) c v n x)
(if (rule e (prodn (tag 'range 'r)
   (list 'OPEN_PAREN (tag 'range_limits 'r2)
 'CLOSE_PAREN)))
    (GF_modifiers bv (subtree e 'range_limits) c v n x)
(if (rule e (prodn (tag 'range_limits 'r)
   (list (tag 'expression 'lo) 'DOT_DOT
 (tag 'expression 'hi))))
    (subsequence_get bv
     (GF (subtree_i e 'expression 1) c v n x)
     (GF (subtree_i e 'expression 2) c v n x))
(if (rule e (prodn (tag 'value_modifiers 'm)
   (tag 'value_alterations 'a)))
    (GF_modifiers bv (subtree e 'value_alterations) c v n x)
(if (rule e (prodn (tag 'value_alterations 'a)
   (list 'WITH 'OPEN_PAREN
 (tag 'component_alterations_list 'al)
 'CLOSE_PAREN)))
    (GF_modifiers bv (subtree e 'component_alterations_list) c v n x)
(if (rule e (prodn (tag 'component_alterations_list 'al)
   (tag 'component_alterations 'a)))

    (GF_modifiers bv (subtree e 'component_alterations) c v n x)
(if (rule e (prodn (tag 'component_alterations_list 'al)
   (list (tag 'component_alterations_list 'al2)
 'SEMI_COLON (tag 'component_alterations 'a))))
    (GF_modifiers (GF_modifiers bv (subtree e 'component_alterations_list)
c v n x)
  (subtree e 'component_alterations) c v n x)
(if (rule e (prodn (tag 'component_alterations 'as)
   (list (tag 'opt_each_clause 'e)
 (tag 'component_assignment 'a))))
    (if (each_clausep (subtree e 'opt_each_clause))
(let ((vs (bound_values (subtree e 'opt_each_clause) c x)))
  (if (errorp vs)
(marked vs (default_value (base_type (type bv))))
    (GF_each (bound_id (subtree e 'opt_each_clause))
     vs bv (subtree e 'component_assignment) c v n x)))
(GF_modifiers bv (subtree e 'component_assignment) c v n x))
(if (rule e (prodn (tag 'component_alterations 'as)
   (list (tag 'opt_each_clause 'e)
 (tag 'component_creation 'c))))
    (if (each_clausep (subtree e 'opt_each_clause))
(let ((vs (bound_values (subtree e 'opt_each_clause) c x)))
  (if (errorp vs)
(marked vs (default_value (base_type (type bv))))
    (GF_each (bound_id (subtree e 'opt_each_clause))
     vs bv (subtree e 'component_creation) c v n x)))
(GF_modifiers bv (subtree e 'component_creation) c v n x))
(if (rule e (prodn (tag 'component_alterations 'as)
   (list (tag 'opt_each_clause 'e)
 (tag 'component_deletion 'd))))
    (if (each_clausep (subtree e 'opt_each_clause))
(let ((vs (bound_values (subtree e 'opt_each_clause) c x)))
  (if (errorp vs)
(marked vs (default_value (base_type (type bv))))
    (GF_each (bound_id (subtree e 'opt_each_clause))
     vs bv (subtree e 'component_deletion) c v n x)))
(GF_modifiers bv (subtree e 'component_deletion) c v n x))
(if (rule e (prodn (tag 'component_assignment 'a)
   (list (tag 'selector_list 's)

   'COLON_EQUAL (tag 'expression 'e))))
      (put_op bv
      (GF_selectors (subtree e 'selector_list) c v n x)
      (GF (subtree e 'expression) c v n x))
  (if (rule e (prodn (tag 'component_creation 'c)
     (list 'BEFORE (tag 'selector_list 's)
   'COLON_EQUAL (tag 'expression 'e))))
      (let ((s (GF_selectors (subtree e 'selector_list) c v n x))
    (u (GF (subtree e 'expression) c v n x)))
(put_op bv (rcdr s)
(Gseq_insert_before (select_op bv (rcdr s)) (rcar s) u)))
  (if (rule e (prodn (tag 'component_creation 'c)
     (list 'BEHIND (tag 'selector_list 's)
   'COLON_EQUAL (tag 'expression 'e))))
      (let ((s (GF_selectors (subtree e 'selector_list) c v n x))
    (u (GF (subtree e 'expression) c v n x)))
(put_op bv (rcdr s)
(Gseq_insert_behind (select_op bv (rcdr s)) (rcar s) u)))
  (if (rule e (prodn (tag 'component_creation 'c)
     (list 'INTO (tag 'selector_list 's)
   'COLON_EQUAL (tag 'expression 'e))))
      (let ((s (GF_selectors (subtree e 'selector_list) c v n x))
    (u (GF (subtree e 'expression) c v n x)))
(put_op bv (rcdr s)
(Gmap_insert (select_op bv (rcdr s)) (rcar s) u)))
  (if (rule e (prodn (tag 'component_deletion 'd)
     (list 'SEQOMIT (tag 'selector_list 's))))
      (let ((s (GF_selectors (subtree e 'selector_list) c v n x)))
(put_op bv (rcdr s)
(Gseqomit (select_op bv (rcdr s)) (rcar s))))
  (if (rule e (prodn (tag 'component_deletion 'd)
     (list 'MAPOMIT (tag 'selector_list 's))))
      (let ((s (GF_selectors (subtree e 'selector_list) c v n x)))
(put_op bv (rcdr s)
(Gmapomit (select_op bv (rcdr s)) (rcar s))))
    (marked (bad_value_modifiers_error e)
    (default_value (base_type (type bv)))))))))))))))))))))))

  ( (ord-lessp (cons (cons (add1 n)
   (add1 (tree_size e)))
     (count c))) )) ; (count c) is a place filler

; ************************************
;  Name references and function calls
; ************************************
(defn apply_fun (fn d sn n x)
  (let ((h (car (ref fn sn x)))  ; scope fn is declared in
(u (cdr (ref fn sn x)))) ; the function declaration
    (if (or (equal (kind u) 'function)
    (equal (kind u) 'constant))
(let ((ftype (type_desc (result_type u) h nil x))
      (fs (formal_dargs u)))                  ; formals
(let ((a (if (equal (length fs) 0) nil d))    ; actuals
      (s (if (equal (length fs) 0) d nil)))   ; selectors
  (if (zerop (fix n))
      (marked (n_too_small)
      (default_value ftype))
    (select_op
     (let ((arg_err (farg_check fs a h x)))
       (if (equal arg_err nil)
   (let ((v (add_to_map (bind_args fs a h x)
(mk_entry_name 'result)
(std_initial
 (list (marked 'type_descriptor
       ftype))))))
     (if (Gtruep (GF (GF_prec u) h v (sub1 n) x))
 (if (has_defn u ftype)
     (let ((r (GF (Gdefn u ftype)
  h v (sub1 n) x)))
       (if (and (determinate r)
(truep (in_type ftype r)))
   (marked nil
   (typed ftype (value r)))
 (marked
   (indeterminate_fn_result_error fn sn)
   (default_value ftype))))
   (marked (no_function_defn_error fn sn)
   (default_value ftype)))
       (marked (entry_not_true_error fn sn)

 (default_value ftype))))
(marked arg_err (default_value ftype))))
s))))
(if (equal (kind u) 'error)
(marked u (default_value (integer_desc)))
(marked (not_function_or_const_error fn sn)
(default_value (integer_desc))))))
( (ord-lessp (cons (cons (add1 n)
(add1 (tree_size fn)))
(tree_size fn))) ))
(defn Gapply (fn ap sn v n x)
(if (free_variablep fn v)
(apply_var fn v ap)
(if (equal fn 'false)
(select_op (Gfalse) ap)
(if (equal fn 'true)
(select_op (Gtrue) ap)
(if (type_name_expp fn ap sn x)
(marked 'type_descriptor
(type_desc (mk_identifier fn) sn nil x))
(if (equal fn 'domain)
(std_domain ap)
(if (equal fn 'first)
(std_first ap)
(if (equal fn 'initial)
(std_initial ap)
(if (equal fn 'last)
(std_last ap)
(if (equal fn 'lower)
(std_lower ap)
(if (equal fn 'max)
(std_max ap)
(if (equal fn 'min)
(std_min ap)
(if (equal fn 'nonfirst)
(std_nonfirst ap)
(if (equal fn 'nonlast)
(std_nonlast ap)
(if (equal fn 'null)
(std_null ap)
(if (equal fn 'ord)
(std_ord ap)
(if (equal fn 'pred)

    (std_pred ap)
(if (equal fn 'range)
    (std_range ap)
(if (equal fn 'scale)
    (std_scale ap)
(if (equal fn 'size)
    (std_size ap)
(if (equal fn 'succ)
    (std_succ ap)
(if (equal fn 'upper)
    (std_upper ap)
  (apply_fun fn ap sn n x))))))))))))))))))))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size fn)))
   (add1 (tree_size fn)))) ))

(defn GF (e c v n x)
; The meta-function GF(e,c,v,n,x) gives the value that results when the
; expression e is evaluated, in the context of scope c with free variables
; bound as determined in the environment v, by at most n applications of
; functions described by the Gypsy sentence x.
;
; The domain and range of GF(e,c,v,n,x) are as follows:
;
;   e is the parse tree representing the expression to be evaluated.
;   c is the (litatom) name of the Gypsy scope in which e is evaluated.
;   v is the name-value mapping that maps names of free variables
;     into their (marked typed) values.
;   n is the maximum allowed depth of Gypsy function calls and quantifiers
;   x is the parse tree representing the Gypsy sentence that is being
;     interpreted.  This is the complete sentence containing the list of all
;     available scopes.
;   GF(e,c,v,n,x) is the marked, typed value that results from evaluating e.
;

; ************************
;
;    <expression> ::= ...
;
; ************************

(if (rule e (prodn (tag 'expression 'e)
   (tag 'modified_primary_value 'm)))
    (GF (subtree e 'modified_primary_value) c v n x)
(if (rule e (prodn (tag 'expression 'e)
   (list 'ALL (tag 'bound_expression 'b))))
    (let ((vs (bound_values e c x)))
(if (errorp vs)
  (marked vs (default_value (boolean_desc)))
(GF_all (bound_id (subtree e 'bound_expression))
vs (cdr_quantified_exp e) c v n x)))
(if (rule e (prodn (tag 'expression 'e)
   (list 'SOME (tag 'bound_expression 'b))))
    (let ((vs (bound_values e c x)))
(if (errorp vs)
  (marked vs (default_value (boolean_desc)))
(GF_some (bound_id (subtree e 'bound_expression))
 vs (cdr_quantified_exp e) c v n x)))
(if (rule e (prodn (tag 'expression 'e)
   (list (tag 'unary_operator 'op) (tag 'expression 'e2))))
    (apply_unary_op (subtree e 'unary_operator)
    (GF (subtree e 'expression) c v n x))
(if (rule e (prodn (tag 'expression 'e)
   (list (tag 'expression 'e1) (tag 'binary_operator 'op)
 (tag 'expression 'e2))))
    (apply_binary_op (subtree e 'binary_operator)
     (GF (subtree_i e 'expression 1) c v n x)
     (GF (subtree_i e 'expression 2) c v n x))

; ********************************
;
;    <modified primary value> ::=
;
; ********************************
(if (rule e (prodn (tag 'modified_primary_value 'm)
   (tag 'primary_value 'p)))
    (GF (subtree e 'primary_value) c v n x)
(if (rule e (prodn (tag 'modified_primary_value 'm)

   (list (tag 'modified_primary_value 'm2)
 (tag 'value_modifiers 'vm))))
    (if (fn_call_formp e)
(Gapply (object_name (subtree e 'modified_primary_value))
(GF_adp (arg_list (subtree e 'value_modifiers))
c v n x)
c v n x)
(GF_modifiers (GF (subtree e 'modified_primary_value) c v n x)
    (subtree e 'value_modifiers) c v n x))
(if (rule e (prodn (tag 'modified_primary_value 'm)
   (list (tag 'modified_primary_value 'm2)
 (tag 'actual_condition_parameters 'cp))))
    ; Condition parameters allowed only in <specification expression>
    ; with validation directive (p. 35, Gypsy 2.05 Report).
    ; **** Weed them out before calling GF in that case. ****
    (let ((r (GF (subtree e 'modified_primary_value) c v n x)))
(marked (condition_params_error e)
(default_value (type r))))

; ***********************
;
;    <primary value> ::=
;
; ***********************
(if (rule e (prodn (tag 'primary_value 'p)
   (tag 'literal_value 'l)))
    (GF (subtree e 'literal_value) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)
   (tag 'set_or_sequence_value 's)))
    (GF (subtree e 'set_or_sequence_value) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)
   (tag 'ENTRY_VALUE 'e)))
    (GF (subtree e 'ENTRY_VALUE) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)
   (tag 'IDENTIFIER 'on)))
    (GF (subtree e 'IDENTIFIER) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)

   (tag 'if_expression 'i)))
    (GF (subtree e 'if_expression) c v n x)
(if (rule e (prodn (tag 'primary_value 'p)
   (list 'OPEN_PAREN (tag 'expression 'e) 'CLOSE_PAREN)))
    (GF (subtree e 'expression) c v n x)

; --------------------------------------------------------------------------
;
;  From here down to parse tree leaves, clauses are in alphabetical order
;  by the left-hand side of the productions.  Everything that is a parse
;  tree for an expression should be covered.
;
; --------------------------------------------------------------------------

; ***********************
;
;    <constant body> ::=
;
; ***********************
; I don't think the following needs to be here.  siebert 9/Sept/90
(if (rule e (prodn (tag 'constant_body 'b)
   (tag 'expression 'e)))
    (GF (subtree e 'expression) c v n x)

; ***********************
;
;    <if expression> ::=
;
; ***********************
(if (rule e (prodn (tag 'if_expression 'i)
   (list 'IF (tag 'expression 'b) 'THEN
 (tag 'expression 'p)
 (tag 'if_expression_else_part 'e))))
    ; Note:  this does not require all potential value expressions to be the
    ; same type or all boolean expressions to be boolean.
    (let ((bv (GF (subtree_i e 'expression 1) c v n x)))
(if (indeterminate bv)

  (marked (mark bv)
  (default_value
    (type (GF (subtree_i e 'expression 2)
c v n x))))
      (if (truep (in_type (boolean_desc) bv))
  (if (Gtruep bv)
(GF (subtree_i e 'expression 2) c v n x)
    (GF (if_else_exp (subtree e 'if_expression_else_part))
c v n x))
(marked (if_test_not_boolean_error e c)
(default_value
  (type (GF (subtree_i e 'expression 2)
    c v n x)))))))

; ***********************
;
;    <literal value> ::=
;
; ***********************
(if (rule e (prodn (tag 'literal_value 'l)
   (tag 'CHARACTER_VALUE 'ch)))
    (GF (subtree e 'CHARACTER_VALUE) c v n x)
(if (rule e (prodn (tag 'literal_value 'l)
   (tag 'number 'n)))
    (GF (subtree e 'number) c v n x)
(if (rule e (prodn (tag 'literal_value 'l)
   (tag 'STRING_VALUE 's)))
    (GF (subtree e 'STRING_VALUE) c v n x)

; ****************
;
;    <number> ::=
;
; ****************
(if (rule e (prodn (tag 'number 'n)
   (tag 'DIGIT_LIST 's)))
    (minteger e)

(if (rule e (prodn (tag 'number 'n)
   (list (tag 'base 'b) (tag 'DIGIT_LIST 's))))
    (minteger e)

; *****************************************
;
;    <pre-computable label expression> ::=
;
; *****************************************
(if (rule e (prodn (tag 'pre_computable_label_expression 'p)
   (tag 'number 'n)))
    (GF (subtree e 'number) c v n x)
(if (rule e (prodn (tag 'pre_computable_label_expression 'p)
   (list 'MINUS (tag 'number 'n))))
    (apply_unary_op (mk_unary_operator 'MINUS)
    (GF (subtree e 'number) c v n x))
(if (rule e (prodn (tag 'pre_computable_label_expression 'p)
   (tag 'CHARACTER_VALUE 'ch)))
    (GF (subtree e 'CHARACTER_VALUE) c v n x)
(if (rule e (prodn (tag 'pre_computable_label_expression 'p)
   (tag 'IDENTIFIER 'i)))
    (GF (subtree e 'IDENTIFIER) c v n x)

; ********************************
;
;    <set or sequence value> ::=
;
; ********************************
(if (rule e (prodn (tag 'set_or_sequence_value 's)
   (list 'OPEN_PAREN (tag 'set_or_seq_mark 'm)
 (tag 'element_list 'e) 'CLOSE_PAREN)))
    (Gset_or_seq (subtree e 'set_or_seq_mark)
 (GF_element_list (subtree e 'element_list) c v n x)
 (GF_element_type (subtree e 'element_list) c v n x))
(if (rule e (prodn (tag 'set_or_sequence_value 's)
   (tag 'range 'r)))

    (Gset_or_seq nil
 (GF_element_list (subtree e 'range) c v n x)
 (GF_element_type (subtree e 'range) c v n x))

; *********************
;
;    PARSE TREE LEAVES
;
; *********************
(if (character_valuep e)
    (Gchar e)
(if (digit_listp e)
    (minteger e)
(if (entry_valuep e)
    (apply_var (entry_name e) v nil)
(if (identifierp e)
    (Gapply (gname e) nil c v n x)
(if (string_valuep e)
    (Gstring_seq e)
  (marked (not_expression_error e) (default_value (integer_desc)))
  ))))))))))))))))))))))))))))))))
( (ord-lessp (cons (cons (add1 n)
 (add1 (tree_size e)))
   (count c))) )) ; (count c) is a place filler
))
|#
(DEFN MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
                                 (MUTUAL-FLG AP BV C D E FN ID N SN V VS X)
                                 (CASE MUTUAL-FLG
                                  (GF
                                   (COND
                                    ((RULE E
                                           (PRODN (TAG 'EXPRESSION 'E)
                                                  (TAG 'MODIFIED_PRIMARY_VALUE 'M)))

(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'MODIFIED_PRIMARY_VALUE)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'EXPRESSION 'E)
(LIST 'ALL
(TAG 'BOUND_EXPRESSION 'B))))
(IF
(ERRORP (BOUND_VALUES E C X))
(MARKED (BOUND_VALUES E C X)
(DEFAULT_VALUE (BOOLEAN_DESC)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ALL
T T
C T
(CDR_QUANTIFIED_EXP E)
T
(BOUND_ID (SUBTREE E 'BOUND_EXPRESSION))
N T
V
(BOUND_VALUES E C X)
X)))
((RULE E
(PRODN (TAG 'EXPRESSION 'E)
(LIST 'SOME
(TAG 'BOUND_EXPRESSION 'B))))
(IF
(ERRORP (BOUND_VALUES E C X))
(MARKED (BOUND_VALUES E C X)
(DEFAULT_VALUE (BOOLEAN_DESC)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SOME
T T

C T
(CDR_QUANTIFIED_EXP E)
T
(BOUND_ID (SUBTREE E 'BOUND_EXPRESSION))
N T
V
(BOUND_VALUES E C X)
X)))
((RULE E
(PRODN (TAG 'EXPRESSION 'E)
(LIST (TAG 'UNARY_OPERATOR 'OP)
(TAG 'EXPRESSION 'E2))))
(APPLY_UNARY_OP
(SUBTREE E 'UNARY_OPERATOR)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'EXPRESSION)
T
T
N
T
V
T
X)))
((RULE E
(PRODN (TAG 'EXPRESSION 'E)
(LIST (TAG 'EXPRESSION 'E1)
(TAG 'BINARY_OPERATOR 'OP)
(TAG 'EXPRESSION 'E2))))
(APPLY_BINARY_OP
(SUBTREE E 'BINARY_OPERATOR)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 1)
T
T

N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 2)
T
T
N
T
V
T
X)))
((RULE E
(PRODN (TAG 'MODIFIED_PRIMARY_VALUE 'M)
(TAG 'PRIMARY_VALUE 'P)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
 'GF
 T
 T
 C
 T
 (SUBTREE E 'PRIMARY_VALUE)
 T
 T
 N
 T
 V
 T
 X))
((RULE E
(PRODN (TAG 'MODIFIED_PRIMARY_VALUE 'M)
(LIST (TAG 'MODIFIED_PRIMARY_VALUE 'M2)
(TAG 'VALUE_MODIFIERS 'VM))))
(IF
(FN_CALL_FORMP E)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GAPPLY

(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ADP
T T C
T
(ARG_LIST (SUBTREE E 'VALUE_MODIFIERS))
T T N
T V T
X)
T T T T
(OBJECT_NAME (SUBTREE E 'MODIFIED_PRIMARY_VALUE))
T N C V T X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'MODIFIED_PRIMARY_VALUE)
T
T
N
T
V
T
X)
C T
(SUBTREE E 'VALUE_MODIFIERS)
T T N T V T X)))
((RULE E
(PRODN (TAG 'MODIFIED_PRIMARY_VALUE 'M)
(LIST (TAG 'MODIFIED_PRIMARY_VALUE 'M2)
(TAG 'ACTUAL_CONDITION_PARAMETERS
'CP))))
(MARKED
(CONDITION_PARAMS_ERROR E)
(DEFAULT_VALUE
(TYPE
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T

T
(SUBTREE E 'MODIFIED_PRIMARY_VALUE)
T
T
N
T
V
T
X)))))
((RULE E
(PRODN (TAG 'PRIMARY_VALUE 'P)
(TAG 'LITERAL_VALUE 'L)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'LITERAL_VALUE)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'PRIMARY_VALUE 'P)
(TAG 'SET_OR_SEQUENCE_VALUE 'S)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'SET_OR_SEQUENCE_VALUE)
T
T
N
T
V
T
X))

((RULE E
(PRODN (TAG 'PRIMARY_VALUE 'P)
(TAG 'ENTRY_VALUE 'E)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'ENTRY_VALUE)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'PRIMARY_VALUE 'P)
(TAG 'IDENTIFIER 'ON)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
 'GF
 T
 T
 C
 T
 (SUBTREE E 'IDENTIFIER)
 T
 T
 N
 T
 V
 T
 X))
((RULE E
(PRODN (TAG 'PRIMARY_VALUE 'P)
(TAG 'IF_EXPRESSION 'I)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'IF_EXPRESSION)

T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'PRIMARY_VALUE 'P)
(LIST 'OPEN_PAREN
(TAG 'EXPRESSION 'E)
'CLOSE_PAREN)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'EXPRESSION)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'CONSTANT_BODY 'B)
(TAG 'EXPRESSION 'E)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'EXPRESSION)
T
T
N
T
V
T
X))
((RULE E

(PRODN (TAG 'IF_EXPRESSION 'I)
(LIST 'IF
(TAG 'EXPRESSION 'B)
'THEN
(TAG 'EXPRESSION 'P)
(TAG 'IF_EXPRESSION_ELSE_PART 'E))))
(COND
((INDETERMINATE
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 1)
T
T
N
T
V
T
X))
(MARKED
(MARK
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 1)
T
T
N
T
V
T
X))
(DEFAULT_VALUE
(TYPE
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T

T
(SUBTREE_I E 'EXPRESSION 2)
T
T
N
T
V
T
X)))))
((TRUEP
(IN_TYPE
(BOOLEAN_DESC)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 1)
T
T
N
T
V
T
X)))
(IF
(GTRUEP
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 1)
T
T
N
T
V
T
X))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST

'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 2)
T
T
N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T T C T
(IF_ELSE_EXP (SUBTREE E 'IF_EXPRESSION_ELSE_PART))
T T N T V T X)))
(T
(MARKED
(IF_TEST_NOT_BOOLEAN_ERROR E C)
(DEFAULT_VALUE
(TYPE
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 2)
T
T
N
T
V
T
X)))))))
((RULE E
(PRODN (TAG 'LITERAL_VALUE 'L)
(TAG 'CHARACTER_VALUE 'CH)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T

T
(SUBTREE E 'CHARACTER_VALUE)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'LITERAL_VALUE 'L)
(TAG 'NUMBER 'N)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'NUMBER)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'LITERAL_VALUE 'L)
(TAG 'STRING_VALUE 'S)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'STRING_VALUE)
T
T
N
T
V
T
X))

((RULE E
(PRODN (TAG 'NUMBER 'N)
(TAG 'DIGIT_LIST 'S)))
(MINTEGER E))
((RULE E
(PRODN (TAG 'NUMBER 'N)
(LIST (TAG 'BASE 'B)
(TAG 'DIGIT_LIST 'S))))
(MINTEGER E))
((RULE E
(PRODN (TAG 'PRE_COMPUTABLE_LABEL_EXPRESSION
'P)
(TAG 'NUMBER 'N)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'NUMBER)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'PRE_COMPUTABLE_LABEL_EXPRESSION
'P)
(LIST 'MINUS (TAG 'NUMBER 'N))))
(APPLY_UNARY_OP
(MK_UNARY_OPERATOR 'MINUS)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'NUMBER)
T
T
N
T

         T
         X)))
((RULE E
(PRODN (TAG 'PRE_COMPUTABLE_LABEL_EXPRESSION
'P)
(TAG 'CHARACTER_VALUE 'CH)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'CHARACTER_VALUE)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'PRE_COMPUTABLE_LABEL_EXPRESSION
'P)
(TAG 'IDENTIFIER 'I)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
     'GF
     T
     T
     C
     T
     (SUBTREE E 'IDENTIFIER)
     T
     T
     N
     T
     V
     T
     X))
((RULE E
(PRODN (TAG 'SET_OR_SEQUENCE_VALUE 'S)
(LIST 'OPEN_PAREN
(TAG 'SET_OR_SEQ_MARK 'M)
(TAG 'ELEMENT_LIST 'E)

'CLOSE_PAREN)))
(GSET_OR_SEQ
(SUBTREE E 'SET_OR_SEQ_MARK)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ELEMENT_LIST
T
T
C
T
(SUBTREE E 'ELEMENT_LIST)
T
T
N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ELEMENT_TYPE
T
T
C
T
(SUBTREE E 'ELEMENT_LIST)
T
T
N
T
V
T
X)))
((RULE E
(PRODN (TAG 'SET_OR_SEQUENCE_VALUE 'S)
(TAG 'RANGE 'R)))
(GSET_OR_SEQ NIL
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
       'GF_ELEMENT_LIST
       T
       T
       C
       T
       (SUBTREE E 'RANGE)
       T
       T

N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ELEMENT_TYPE
T
T
C
T
(SUBTREE E 'RANGE)
T
T
N
T
V
T
X)))
((CHARACTER_VALUEP E) (GCHAR E))
((DIGIT_LISTP E) (MINTEGER E))
((ENTRY_VALUEP E)
(APPLY_VAR (ENTRY_NAME E) V NIL))
((IDENTIFIERP E)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
          'GAPPLY
          NIL
          T
          T
          T
          T
          (GNAME E)
          T
          N
          C
          V
          T
          X))
((STRING_VALUEP E) (GSTRING_SEQ E))
(T (MARKED (NOT_EXPRESSION_ERROR E)
(DEFAULT_VALUE (INTEGER_DESC))))))
(GAPPLY
(COND
((FREE_VARIABLEP FN V)

 (APPLY_VAR FN V AP))
((EQUAL FN 'FALSE)
 (SELECT_OP (GFALSE) AP))
((EQUAL FN 'TRUE)
 (SELECT_OP (GTRUE) AP))
((TYPE_NAME_EXPP FN AP SN X)
 (MARKED 'TYPE_DESCRIPTOR
         (TYPE_DESC (MK_IDENTIFIER FN)
                    SN NIL X)))
((EQUAL FN 'DOMAIN) (STD_DOMAIN AP))
((EQUAL FN 'FIRST) (STD_FIRST AP))
((EQUAL FN 'INITIAL)
 (STD_INITIAL AP))
((EQUAL FN 'LAST) (STD_LAST AP))
((EQUAL FN 'LOWER) (STD_LOWER AP))
((EQUAL FN 'MAX) (STD_MAX AP))
((EQUAL FN 'MIN) (STD_MIN AP))
((EQUAL FN 'NONFIRST)
 (STD_NONFIRST AP))
((EQUAL FN 'NONLAST)
 (STD_NONLAST AP))
((EQUAL FN 'NULL) (STD_NULL AP))
((EQUAL FN 'ORD) (STD_ORD AP))
((EQUAL FN 'PRED) (STD_PRED AP))
((EQUAL FN 'RANGE) (STD_RANGE AP))
((EQUAL FN 'SCALE) (STD_SCALE AP))
((EQUAL FN 'SIZE) (STD_SIZE AP))
((EQUAL FN 'SUCC) (STD_SUCC AP))
((EQUAL FN 'UPPER) (STD_UPPER AP))
(T
 (MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
                                                                'APPLY_FUN
                                                                T
                                                                T
                                                                T
                                                                AP
                                                                T
                                                                FN
                                                                T
                                                                N
                                                                SN
                                                                T
                                                                T
                                                                X))))

(APPLY_FUN
(COND
((OR (EQUAL (KIND (CDR (REF FN SN X)))
     'FUNCTION)
(EQUAL (KIND (CDR (REF FN SN X)))
     'CONSTANT))
(IF
(ZEROP (FIX N))
(MARKED (N_TOO_SMALL)
   (DEFAULT_VALUE (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                             (CAR (REF FN SN X))
                             NIL
                             X)))
(SELECT_OP
(IF
(EQUAL
  (FARG_CHECK (FORMAL_DARGS (CDR (REF FN SN X)))
              (IF (EQUAL (LENGTH (FORMAL_DARGS (CDR (REF FN SN X))))
                         0)
                  NIL D)
              (CAR (REF FN SN X))
              X)
  NIL)
(IF
(GTRUEP
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T T
(CAR (REF FN SN X))
T
(GF_PREC (CDR (REF FN SN X)))
T T
(SUB1 N)
T
(ADD_TO_MAP
 (BIND_ARGS (FORMAL_DARGS (CDR (REF FN SN X)))
            (IF (EQUAL (LENGTH (FORMAL_DARGS (CDR (REF FN SN X))))
                       0)
                NIL D)
            (CAR (REF FN SN X))
            X)
 (MK_ENTRY_NAME 'RESULT)
 (STD_INITIAL
          (LIST (MARKED 'TYPE_DESCRIPTOR

                     (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                                (CAR (REF FN SN X))
                                NIL
                                X)))))
T X))
(IF
(HAS_DEFN (CDR (REF FN SN X))
      (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                 (CAR (REF FN SN X))
                 NIL X))
(IF
(AND
(DETERMINATE
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T T
(CAR (REF FN SN X))
T
(GDEFN (CDR (REF FN SN X))
       (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                  (CAR (REF FN SN X))
                  NIL X))
T T
(SUB1 N)
T
(ADD_TO_MAP
 (BIND_ARGS
           (FORMAL_DARGS (CDR (REF FN SN X)))
           (IF (EQUAL (LENGTH (FORMAL_DARGS (CDR (REF FN SN X))))
                      0)
               NIL D)
           (CAR (REF FN SN X))
           X)
 (MK_ENTRY_NAME 'RESULT)
 (STD_INITIAL
       (LIST (MARKED 'TYPE_DESCRIPTOR
                     (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                                (CAR (REF FN SN X))
                                NIL
                                X)))))
T X))
(TRUEP
(IN_TYPE
(TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))

          (CAR (REF FN SN X))
          NIL X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T T
(CAR (REF FN SN X))
T
(GDEFN (CDR (REF FN SN X))
       (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                  (CAR (REF FN SN X))
                  NIL X))
T T
(SUB1 N)
T
(ADD_TO_MAP
 (BIND_ARGS
          (FORMAL_DARGS (CDR (REF FN SN X)))
          (IF (EQUAL (LENGTH (FORMAL_DARGS (CDR (REF FN SN X))))
                     0)
              NIL D)
          (CAR (REF FN SN X))
          X)
 (MK_ENTRY_NAME 'RESULT)
 (STD_INITIAL
      (LIST (MARKED 'TYPE_DESCRIPTOR
                    (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                               (CAR (REF FN SN X))
                               NIL
                               X)))))
T X))))
(MARKED NIL
(TYPED
(TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
         (CAR (REF FN SN X))
         NIL X)
(VALUE
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T T
(CAR (REF FN SN X))
T
(GDEFN (CDR (REF FN SN X))
       (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                  (CAR (REF FN SN X))

        NIL X))
T T
(SUB1 N)
T
(ADD_TO_MAP
(BIND_ARGS
(FORMAL_DARGS (CDR (REF FN SN X)))
(IF (EQUAL (LENGTH (FORMAL_DARGS (CDR (REF FN SN X))))
           0)
    NIL D)
(CAR (REF FN SN X))
X)
(MK_ENTRY_NAME 'RESULT)
(STD_INITIAL
(LIST (MARKED 'TYPE_DESCRIPTOR
          (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                     (CAR (REF FN SN X))
                     NIL
                     X)))))
T X))))
(MARKED (INDETERMINATE_FN_RESULT_ERROR FN SN)
(DEFAULT_VALUE (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                    (CAR (REF FN SN X))
                    NIL
                    X))))
(MARKED (NO_FUNCTION_DEFN_ERROR FN SN)
(DEFAULT_VALUE (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                   (CAR (REF FN SN X))
                   NIL
                   X))))
(MARKED (ENTRY_NOT_TRUE_ERROR FN SN)
(DEFAULT_VALUE (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
                  (CAR (REF FN SN X))
                  NIL
                  X))))
(MARKED
(FARG_CHECK (FORMAL_DARGS (CDR (REF FN SN X)))
(IF (EQUAL (LENGTH (FORMAL_DARGS (CDR (REF FN SN X))))
           0)
    NIL D)
(CAR (REF FN SN X))
X)
(DEFAULT_VALUE (TYPE_DESC (RESULT_TYPE (CDR (REF FN SN X)))
              (CAR (REF FN SN X))

NIL
X))))
(IF (EQUAL (LENGTH (FORMAL_DARGS (CDR (REF FN SN X))))
0)
D NIL))))
((EQUAL (KIND (CDR (REF FN SN X)))
'ERROR)
(MARKED (CDR (REF FN SN X))
(DEFAULT_VALUE (INTEGER_DESC))))
(T (MARKED (NOT_FUNCTION_OR_CONST_ERROR FN SN)
(DEFAULT_VALUE (INTEGER_DESC))))))
(GF_MODIFIERS
(COND
((RULE E
(PRODN (TAG 'VALUE_MODIFIERS 'M)
(TAG 'COMPONENT_SELECTORS 'S)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
BV
C
T
(SUBTREE E 'COMPONENT_SELECTORS)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'COMPONENT_SELECTORS 'S)
(LIST 'DOT (TAG 'IDENTIFIER 'FN))))
(RECORD_GET BV
(MARKED 'FIELD_NAME
(GNAME (SUBTREE E 'IDENTIFIER)))
(TYPE BV)))
((RULE E
(PRODN (TAG 'COMPONENT_SELECTORS 'S)
(TAG 'ARG_LIST 'D)))
(SELECT_OP BV
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
           'GF_ADP
           T

T
C
T
(SUBTREE E 'ARG_LIST)
T
T
N
T
V
T
X)))
((RULE E
(PRODN (TAG 'VALUE_MODIFIERS 'M)
(TAG 'RANGE 'R)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
BV
C
T
(SUBTREE E 'RANGE)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'RANGE 'R)
(LIST 'OPEN_PAREN
(TAG 'RANGE_LIMITS 'R2)
'CLOSE_PAREN)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
BV
C
T
(SUBTREE E 'RANGE_LIMITS)
T
T
N
T

  T
  X))
((RULE E
(PRODN (TAG 'RANGE_LIMITS 'R)
(LIST (TAG 'EXPRESSION 'LO)
'DOT_DOT
(TAG 'EXPRESSION 'HI))))
(SUBSEQUENCE_GET BV
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 1)
T
T
N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 2)
T
T
N
T
V
T
X)))
((RULE E
(PRODN (TAG 'VALUE_MODIFIERS 'M)
(TAG 'VALUE_ALTERATIONS 'A)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
BV

       T
       (SUBTREE E 'VALUE_ALTERATIONS)
       T
       T
       N
       T
       V
       T
       X))
((RULE E
(PRODN (TAG 'VALUE_ALTERATIONS 'A)
(LIST 'WITH
'OPEN_PAREN
(TAG 'COMPONENT_ALTERATIONS_LIST
'AL)
'CLOSE_PAREN)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
BV
C
T
(SUBTREE E
         'COMPONENT_ALTERATIONS_LIST)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'COMPONENT_ALTERATIONS_LIST
'AL)
(TAG 'COMPONENT_ALTERATIONS 'A)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
   'GF_MODIFIERS
   T
   BV
   C
   T
   (SUBTREE E 'COMPONENT_ALTERATIONS)
   T

   T
   N
   T
   V
   T
   X))
((RULE E
(PRODN (TAG 'COMPONENT_ALTERATIONS_LIST
'AL)
(LIST (TAG 'COMPONENT_ALTERATIONS_LIST
'AL2)
'SEMI_COLON
(TAG 'COMPONENT_ALTERATIONS 'A))))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
BV
C T
(SUBTREE E
         'COMPONENT_ALTERATIONS_LIST)
T T
N T
V T
X)
C T
(SUBTREE E 'COMPONENT_ALTERATIONS)
T T N T V T X))
((RULE E
(PRODN (TAG 'COMPONENT_ALTERATIONS 'AS)
(LIST (TAG 'OPT_EACH_CLAUSE 'E)
(TAG 'COMPONENT_ASSIGNMENT 'A))))
(IF
(EACH_CLAUSEP (SUBTREE E 'OPT_EACH_CLAUSE))
(IF
(ERRORP (BOUND_VALUES (SUBTREE E 'OPT_EACH_CLAUSE)
C X))
(MARKED (BOUND_VALUES (SUBTREE E 'OPT_EACH_CLAUSE)
C X)
(DEFAULT_VALUE (BASE_TYPE (TYPE BV))))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_EACH

T BV C
T
(SUBTREE E 'COMPONENT_ASSIGNMENT)
T
(BOUND_ID (SUBTREE E 'OPT_EACH_CLAUSE))
N T V
(BOUND_VALUES (SUBTREE E 'OPT_EACH_CLAUSE)
              C
              X)
X))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
         'GF_MODIFIERS
         T
         BV
         C
         T
         (SUBTREE E 'COMPONENT_ASSIGNMENT)
         T
         T
         N
         T
         V
         T
         X)))
((RULE E
(PRODN (TAG 'COMPONENT_ALTERATIONS 'AS)
(LIST (TAG 'OPT_EACH_CLAUSE 'E)
(TAG 'COMPONENT_CREATION 'C))))
(IF
(EACH_CLAUSEP (SUBTREE E 'OPT_EACH_CLAUSE))
(IF
(ERRORP (BOUND_VALUES (SUBTREE E 'OPT_EACH_CLAUSE)
C X))
(MARKED (BOUND_VALUES (SUBTREE E 'OPT_EACH_CLAUSE)
C X)
(DEFAULT_VALUE (BASE_TYPE (TYPE BV))))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_EACH
T BV C
T
(SUBTREE E 'COMPONENT_CREATION)
T
(BOUND_ID (SUBTREE E 'OPT_EACH_CLAUSE))
N T V

(BOUND_VALUES (SUBTREE E 'OPT_EACH_CLAUSE)
   C
   X)
X))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
BV
C
T
(SUBTREE E 'COMPONENT_CREATION)
T
T
N
T
V
T
X)))
((RULE E
(PRODN (TAG 'COMPONENT_ALTERATIONS 'AS)
(LIST (TAG 'OPT_EACH_CLAUSE 'E)
(TAG 'COMPONENT_DELETION 'D))))
(IF
(EACH_CLAUSEP (SUBTREE E 'OPT_EACH_CLAUSE))
(IF
(ERRORP (BOUND_VALUES (SUBTREE E 'OPT_EACH_CLAUSE)
C X))
(MARKED (BOUND_VALUES (SUBTREE E 'OPT_EACH_CLAUSE)
C X)
(DEFAULT_VALUE (BASE_TYPE (TYPE BV))))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_EACH
T BV C
T
(SUBTREE E 'COMPONENT_DELETION)
T
(BOUND_ID (SUBTREE E 'OPT_EACH_CLAUSE))
N T V
(BOUND_VALUES (SUBTREE E 'OPT_EACH_CLAUSE)
   C
   X)
X))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS

T
BV
C
T
(SUBTREE E 'COMPONENT_DELETION)
T
T
N
T
V
T
X)))
((RULE E
(PRODN (TAG 'COMPONENT_ASSIGNMENT 'A)
(LIST (TAG 'SELECTOR_LIST 'S)
'COLON_EQUAL
(TAG 'EXPRESSION 'E))))
(PUT_OP BV
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
   'GF
   T
   T
   C
   T
   (SUBTREE E 'EXPRESSION)
   T
   T
   N
   T
   V

   T
   X)))
((RULE E
(PRODN (TAG 'COMPONENT_CREATION 'C)
(LIST 'BEFORE
(TAG 'SELECTOR_LIST 'S)
'COLON_EQUAL
(TAG 'EXPRESSION 'E))))
(PUT_OP BV
(RCDR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X))
(GSEQ_INSERT_BEFORE
(SELECT_OP BV
(RCDR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X)))
(RCAR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS

T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
   'GF
   T
   T
   C
   T
   (SUBTREE E 'EXPRESSION)
   T
   T
   N
   T
   V
   T
   X))))
((RULE E
(PRODN (TAG 'COMPONENT_CREATION 'C)
(LIST 'BEHIND
(TAG 'SELECTOR_LIST 'S)
'COLON_EQUAL
(TAG 'EXPRESSION 'E))))
(PUT_OP BV
(RCDR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N

T
V
T
X))
(GSEQ_INSERT_BEHIND
(SELECT_OP BV
(RCDR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X)))
(RCAR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
   'GF
   T
   T
   C
   T
   (SUBTREE E 'EXPRESSION)
   T

   T
   N
   T
   V
   T
   X))))
((RULE E
(PRODN (TAG 'COMPONENT_CREATION 'C)
(LIST 'INTO
(TAG 'SELECTOR_LIST 'S)
'COLON_EQUAL
(TAG 'EXPRESSION 'E))))
(PUT_OP BV
(RCDR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X))
(GMAP_INSERT
(SELECT_OP BV
(RCDR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T

X)))
(RCAR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
   'GF
   T
   T
   C
   T
   (SUBTREE E 'EXPRESSION)
   T
   T
   N
   T
   V
   T
   X))))
((RULE E
(PRODN (TAG 'COMPONENT_DELETION 'D)
(LIST 'SEQOMIT
(TAG 'SELECTOR_LIST 'S))))
(PUT_OP BV
(RCDR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T

T
N
T
V
T
X))
(GSEQOMIT
(SELECT_OP BV
(RCDR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X)))
(RCAR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X)))))
((RULE E
(PRODN (TAG 'COMPONENT_DELETION 'D)
(LIST 'MAPOMIT
(TAG 'SELECTOR_LIST 'S))))
(PUT_OP BV
(RCDR

(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X))
(GMAPOMIT
(SELECT_OP BV
(RCDR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X)))
(RCAR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V

T
X)))))
(T (MARKED (BAD_VALUE_MODIFIERS_ERROR E)
(DEFAULT_VALUE (BASE_TYPE (TYPE BV)))))))
(GF_SELECTORS
(COND
((RULE E
(PRODN (TAG 'SELECTOR_LIST 'S)
(TAG 'COMPONENT_SELECTORS 'S2)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'COMPONENT_SELECTORS)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'SELECTOR_LIST 'S)
(LIST (TAG 'SELECTOR_LIST 'S2)
(TAG 'COMPONENT_SELECTORS 'S3))))
(APPEND
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS
T
T
C
T
(SUBTREE E 'SELECTOR_LIST)
T
T
N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_SELECTORS

T
T
C
T
(SUBTREE E 'COMPONENT_SELECTORS)
T
T
N
T
V
T
X)))
((RULE E
(PRODN (TAG 'COMPONENT_SELECTORS 'S)
(LIST 'DOT (TAG 'IDENTIFIER 'FN))))
(LIST (MARKED 'FIELD_NAME
(GNAME (SUBTREE E 'IDENTIFIER)))))
((RULE E
(PRODN (TAG 'COMPONENT_SELECTORS 'S)
(TAG 'ARG_LIST 'D)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ADP
T
T
C
T
(SUBTREE E 'ARG_LIST)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'ARG_LIST 'AS)
(LIST 'OPEN_PAREN
(TAG 'VALUE_LIST 'VS)
'CLOSE_PAREN)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ADP
T
T
C

T
(SUBTREE E 'VALUE_LIST)
T
T
N
T
V
T
X))
(T NIL)))
(GF_ADP
(COND
((RULE E
(PRODN (TAG 'ARG_LIST 'AS)
(LIST 'OPEN_PAREN
(TAG 'VALUE_LIST 'VS)
'CLOSE_PAREN)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ADP
T
T
C
T
(SUBTREE E 'VALUE_LIST)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'VALUE_LIST 'VS)
(TAG 'EXPRESSION 'E)))
(RCONS NIL
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'EXPRESSION)
T
T

N
T
V
T
X)))
((RULE E
(PRODN (TAG 'VALUE_LIST 'VS)
(LIST (TAG 'VALUE_LIST 'VS2)
'COMMA
(TAG 'EXPRESSION 'E))))
(RCONS
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ADP
T
T
C
T
(SUBTREE E 'VALUE_LIST)
T
T
N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'EXPRESSION)
T
T
N
T
V
T
X)))
(T NIL)))
(GF_EACH
(COND
((NLISTP VS) BV)
((NEW_NAMEP ID V)

(IF
(ZEROP N)
(MARKED (N_TOO_SMALL)
(DEFAULT_VALUE (BASE_TYPE (TYPE BV))))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_EACH
T
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_MODIFIERS
T
BV
C
T
E
T
T
(SUB1 N)
T
(ADD_TO_MAP V ID (CAR VS))
T
X)
C T E T ID N T V
(CDR VS)
X)))
(T (MARKED (NAME_ALREADY_IN_USE_ERROR ID)
(DEFAULT_VALUE (BASE_TYPE (TYPE BV)))))))
(GF_SOME
(COND
((NLISTP VS) (GFALSE))
((NEW_NAMEP ID V)
(IF
(ZEROP N)
(MARKED (N_TOO_SMALL)
(DEFAULT_VALUE (BOOLEAN_DESC)))
(GOR
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
                 'GF_SOME
                 T
                 T
                 C
                 T
                 E
                 T
                 ID

N
T
V
(RCDR VS)
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
E
T
T
(SUB1 N)
T
(ADD_TO_MAP V ID (RCAR VS))
T
X))))
(T (MARKED (NAME_ALREADY_IN_USE_ERROR ID)
(DEFAULT_VALUE (BOOLEAN_DESC))))))
(GF_ALL
(COND
((NLISTP VS) (GTRUE))
((NEW_NAMEP ID V)
(IF
(ZEROP N)
(MARKED (N_TOO_SMALL)
(DEFAULT_VALUE (BOOLEAN_DESC)))
(GAND
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ALL
T
T
C
T
E
T
ID
N
T
V
(RCDR VS)
X)

(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
E
T
T
(SUB1 N)
T
(ADD_TO_MAP V ID (RCAR VS))
T
X))))
(T (MARKED (NAME_ALREADY_IN_USE_ERROR ID)
(DEFAULT_VALUE (BOOLEAN_DESC))))))
(GF_ELEMENT_TYPE
(COND
((RULE E
(PRODN (TAG 'RANGE 'R)
(LIST 'OPEN_PAREN
(TAG 'RANGE_LIMITS 'R2)
'CLOSE_PAREN)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
 'GF_ELEMENT_TYPE
 T
 T
 C
 T
 (SUBTREE E 'RANGE_LIMITS)
 T
 T
 N
 T
 V
 T
 X))
((RULE E
(PRODN (TAG 'ELEMENT_LIST 'E)
(TAG 'VALUE_LIST 'V)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
   'GF_ELEMENT_TYPE
   T
   T

  T
  (SUBTREE E 'VALUE_LIST)
  T
  T
  N
  T
  V
  T
  X))
((RULE E
(PRODN (TAG 'ELEMENT_LIST 'E)
(TAG 'RANGE_LIMITS 'R)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ELEMENT_TYPE
T
T
C
T
(SUBTREE E 'RANGE_LIMITS)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'RANGE_LIMITS 'R)
(LIST (TAG 'EXPRESSION 'LO)
'DOT_DOT
(TAG 'EXPRESSION 'HI))))
(BASE_TYPE
(TYPE
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 1)
T
T
N

T
V
T
X))))
((RULE E
(PRODN (TAG 'VALUE_LIST 'V)
(TAG 'EXPRESSION 'E)))
(BASE_TYPE
(TYPE
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'EXPRESSION)
T
T
N
T
V
T
X))))
((RULE E
(PRODN (TAG 'VALUE_LIST 'V)
(LIST (TAG 'VALUE_LIST 'V2)
'COMMA
(TAG 'EXPRESSION 'E))))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ELEMENT_TYPE
T
T
C
T
(SUBTREE E 'VALUE_LIST)
T
T
N
T
V
T
X))
(T NIL)))
(OTHERWISE

(COND
((RULE E
(PRODN (TAG 'RANGE 'R)
(LIST 'OPEN_PAREN
(TAG 'RANGE_LIMITS 'R2)
'CLOSE_PAREN)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ELEMENT_LIST
T
T
C
T
(SUBTREE E 'RANGE_LIMITS)
T
T
N
T
V
T
X))
((RULE E
(PRODN (TAG 'ELEMENT_LIST 'E)
(TAG 'VALUE_LIST 'V)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
  'GF_ELEMENT_LIST
  T
  T
  C
  T
  (SUBTREE E 'VALUE_LIST)
  T
  T
  N
  T
  V
  T
  X))
((RULE E
(PRODN (TAG 'ELEMENT_LIST 'E)
(TAG 'RANGE_LIMITS 'R)))
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ELEMENT_LIST
T
T

  T
  (SUBTREE E 'RANGE_LIMITS)
  T
  T
  N
  T
  V
  T
  X))
((RULE E
(PRODN (TAG 'RANGE_LIMITS 'R)
(LIST (TAG 'EXPRESSION 'LO)
'DOT_DOT
(TAG 'EXPRESSION 'HI))))
(GRANGE_ELEMENTS
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 1)
T
T
N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE_I E 'EXPRESSION 2)
T
T
N
T
V
T
X)))

((RULE E
(PRODN (TAG 'VALUE_LIST 'V)
(TAG 'EXPRESSION 'E)))
(RCONS NIL
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T
(SUBTREE E 'EXPRESSION)
T
T
N
T
V
T
X)))
((RULE E
(PRODN (TAG 'VALUE_LIST 'V)
(LIST (TAG 'VALUE_LIST 'V2)
'COMMA
(TAG 'EXPRESSION 'E))))
(RCONS
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF_ELEMENT_LIST
T
T
C
T
(SUBTREE E 'VALUE_LIST)
T
T
N
T
V
T
X)
(MUTUAL-GF-GAPPLY-APPLY_FUN-GF_MODIFIERS-GF_SELECTORS-GF_ADP-GF_EACH-GF_SOME-GF_ALL-GF_ELEMENT_TYPE-GF_ELEMENT_LIST
'GF
T
T
C
T

                                    (SUBTREE E 'EXPRESSION)
                                    T
                                    T
                                    N
                                    T
                                    V
                                    T
                                    X)))
(T NIL))))
((ORD-LESSP (CASE MUTUAL-FLG
(GF (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE E)))
          (COUNT C)))
(GAPPLY (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE FN)))
              (ADD1 (TREE_SIZE FN))))
(APPLY_FUN (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE FN)))
                 (TREE_SIZE FN)))
(GF_MODIFIERS (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE E)))
                    (COUNT C)))
(GF_SELECTORS (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE E)))
                    (COUNT C)))
(GF_ADP (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE E)))
              (COUNT C)))
(GF_EACH (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE E)))
               (COUNT VS)))
(GF_SOME (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE ID)))
               (COUNT VS)))
(GF_ALL (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE ID)))
              (COUNT VS)))
(GF_ELEMENT_TYPE (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE E)))
                       (COUNT C)))
(OTHERWISE (CONS (CONS (ADD1 N) (ADD1 (TREE_SIZE E)))
                 (COUNT C)))))))

Definition: gf (e, c, v, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gf,

t, t, c, t, e, t, t, n, t, v, t, x)

Definition: gapply (fn, ap, sn, v, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gapply,

ap, t, t, t, t, fn, t, n, sn, v, t, x)

Definition: apply fun (fn, d, sn, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('apply fun,

t, t, t, d, t, fn, t, n, sn, t, t, x)

Definition: gf modifiers (bv, e, c, v, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gf modifiers,

t, bv, c, t, e, t, t, n, t, v, t, x)

Definition: gf selectors (e, c, v, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gf selectors,

t, t, c, t, e, t, t, n, t, v, t, x)

Definition: gf adp (e, c, v, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gf adp,

t, t, c, t, e, t, t, n, t, v, t, x)

Definition: gf each (id, vs, bv, e, c, v, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gf each,

t, bv, t, e, t, id, n, t, v, vs, x)

Definition: gf some (id, vs, e, c, v, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gf some,

t, t, c, t, e, t, id, n, t, v, vs, x)

Definition: gf all (id, vs, e, c, v, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gf all,

t, t, c, t, e, t, id, n, t, v, vs, x)

Definition: gf element type (e, c, v, n, x)

= mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gf element type, t, t, c, t, e, t, t, n, t, v, t, x)

Definition: gf element list (e, c, v, n, x) = mutual-gf-gapply-apply fun-gf modifiers-gf selectors-gf adp-gf each-gf some-gf all-gf element type-gf element list ('gf element list,

t, t, c, t, e, t, t, n, t, v, t, x)

; *********************
;  The Meta Function F
; *********************

Definition: meta f (e, c, v, n, x) = let pte be pt (e, 'expression),

ptx be pt (x, 'program description)

in if pte = nil

then marked ('expression syntax error, nil)

elseif ptx = nil

then marked ('program description syntax error, nil)

else gf (pte, c, v, n, ptx) endif endlet Event: Make the library "gf".

275

Index

access, 46, 60, 177 actual formal type error, 28, 147 add to map, 10, 101, 178 adjoin args error, 28, 158 alias id error, 29, 76 all gypsy type members, 125 all gypsy types, 125, 126 all matches, 10 all scope types, 125 all scope types members, 125 all scopes, 75, 76, 125, 126 all scopes car, 125 all seqs le n, 105, 107 all seqs n, 105 all subsets, 104, 107 all type units, 125 all type units members, 125 all units, 75, 76, 126 all units car, 126 append args error, 29, 161 apply binary op, 161 apply fun, 271 apply unary op, 152 apply var, 174 arg check, 147–160, 162–174, 177 arg list, 46, 47, 184 arg listp, 47, 57 array desc, 127, 138 array descp, 82, 85, 95, 148, 163 array get, 148, 150, 165 array index error, 29, 127 array put, 163, 165 array value set, 105, 108 ascii 0, 3, 7, 8, 145 ascii 1, 3 ascii 2, 3 ascii 3, 3 ascii 4, 3 ascii 5, 3 ascii 6, 3 ascii 7, 3 ascii 8, 3 ascii 9, 3, 7, 145 ascii a, 4, 7, 14, 145 ascii ack, 1 ascii and, 3, 12 ascii at, 4, 12 ascii b, 4 ascii back quote, 5 ascii backslash, 5 ascii bel, 1 ascii bs, 1 ascii c, 4 ascii can, 2 ascii caret, 5 ascii character listp, 7, 13, 180 ascii characterp, 6, 7, 16, 180 ascii close brace, 6 ascii close bracket, 5, 14 ascii close paren, 3, 12, 14 ascii colon, 3, 12, 13 ascii comma, 3, 13 ascii cr, 2 ascii d, 4 ascii dash, 3, 13 ascii dc1, 2 ascii dc2, 2 ascii dc3, 2 ascii dc4, 2 ascii del, 6 ascii dle, 2 ascii dollar, 3 ascii dot, 3, 13 ascii double quote, 3, 16, 147 ascii e, 4 ascii em, 2 ascii enq, 1 ascii eot, 1 ascii equal, 4, 12, 13 ascii esc, 2 ascii etb, 2 ascii etx, 1 ascii exclamation point, 2 ascii f, 4, 14, 145 ascii ff, 2 ascii fs, 2 ascii g, 4 ascii gs, 2 ascii gt, 4, 13 ascii h, 4 ascii ht, 2 ascii i, 4 ascii j, 4 ascii k, 4 ascii l, 4 ascii lc a, 5, 7, 145 ascii lc b, 5 ascii lc c, 5 ascii lc d, 5 ascii lc e, 5 ascii lc f, 5, 145 ascii lc g, 5 ascii lc h, 5 ascii lc i, 5 ascii lc j, 5 ascii lc k, 5 ascii lc l, 5 ascii lc m, 6 ascii lc n, 6 ascii lc o, 6 ascii lc p, 6 ascii lc q, 6 ascii lc r, 6 ascii lc s, 6 ascii lc t, 6 ascii lc u, 6 ascii lc v, 6 ascii lc w, 6 ascii lc x, 6 ascii lc y, 6 ascii lc z, 6, 7 ascii lf, 2 ascii lt, 4, 13 ascii m, 4 ascii n, 4 ascii nak, 2 ascii nul, 1 ascii number sign, 3 ascii o, 4 ascii open brace, 6 ascii open bracket, 5, 14 ascii open paren, 3, 13, 14 ascii p, 4 ascii percent, 3 ascii plus, 3, 13 ascii q, 4 ascii question, 4 ascii r, 4 ascii rs, 2 ascii s, 4 ascii semicolon, 4, 13 ascii si, 2 ascii single quote, 3, 14, 15, 24, 25,

178 ascii slash, 3, 13 ascii so, 2 ascii soh, 1 ascii space, 2, 7 ascii star, 3, 13 ascii stx, 1 ascii sub, 2 ascii syn, 2 ascii t, 5 ascii tilde, 6, 7, 46 ascii u, 5 ascii underscore, 5, 15 ascii us, 2 ascii v, 5 ascii vertical bar, 6 ascii vt, 2 ascii w, 5 ascii x, 5 ascii y, 5 ascii z, 5, 7 available types, 126

bad string error, 29, 147 bad value modifiers error, 29 band, 151, 153 base type, 121, 124, 150–153, 157–

161, 163, 164, 166, 167, 169, 172–174

bimp, 151, 154 bind args, 177 bnot, 151, 152 boolean desc, 83, 142, 145, 152–154,

157 boolean typep, 83, 175 bor, 151, 153 bound boolean expression, 47, 48, 53 bound id, 48, 49, 184 bound id type, 49, 53 bound values, 179 bounded index typep, 84, 180 bounded typep, 83, 84, 105, 115

case exit list, 50–52, 67 case exit list2, 49, 50, 52 cdr quantified exp, 53 cdr quantified names, 52, 53 char digit, 145, 146 character desc, 83, 142, 145, 147 character error, 29, 145 character typep, 83 character value lexemep, 14, 16 character valuep, 16, 18, 145 close bracket lexeme, 14, 16 close paren lexeme, 14, 16 colon gt args error, 30 component assign error, 30, 166 component td, 80, 82, 93–95, 102–

104, 108, 109, 113–115, 120, 121, 123, 124, 148, 149, 157– 159, 163–166, 172

condition params error, 30 constant value exp, 53, 176 construct scalar desc, 132, 140 count cons, 106 count key values, 110 count keys, 110 crd, 80, 81, 120, 123

default initial value, 128, 141 default value, 119, 145–174 derived units, 55, 72 determinate, 117, 129, 145, 157, 164–

167 difference args error, 30, 160 digit list lexemep, 15, 17 digit listp, 17, 18, 24, 146 digit valid, 146 digit value, 146 domain arg error, 30, 167 dparam name, 55, 177, 178 dparam name list, 55, 175, 177 dtype, 116, 117, 124, 127, 170, 171,

173 dtype fields, 116 dtype list, 116 dtype size, 110, 114, 115 duplicate field names error, 31, 128 duplicate param names error, 31, 177

each clausep, 55

each id type error, 31, 180

elif leafp, 181

empty map, 9, 84, 177 empty seq error, 31, 170 empty type error, 31, 131 entry name, 45 entry not true error, 31 entry value lexemep, 15, 17, 25 entry valuep, 17, 18, 45 eq opp, 175 equality typep, 84, 128, 152, 175 error descp, 82, 124, 127, 128, 131,

143, 144 error msg, 28, 81 errorp, 28, 63, 81, 82, 102–107, 109,

110, 113, 115, 118, 119, 122, 129–132, 143, 147–149, 168– 171, 173 expression from spec, 56, 67

f of formals, 175 farg check, 177 fformals check, 177 field base types, 121 field descs, 144 field list sets, 106 field name reserved error, 32, 128 field names, 84, 113, 123, 128 field td, 80, 149, 164 field tds, 80, 82, 95, 108, 113, 120,

123 field tds equal, 124 field value sets, 109 first arg error, 32, 168 fn call formp, 57, 58 foreign name, 58, 76 foreign scope name, 58, 59, 76 formal dargs, 59, 60, 175 formal type, 61, 177, 178 formal type list, 176, 177 free value, 174 free variablep, 174 fselect, 85, 95, 101, 149 full dargs, 59, 60 function access error, 32, 177 function defn, 175, 176

gadjoin, 158, 162 gand, 153, 154, 161 gappend, 160–162, 166, 167 gapply, 271 gchar, 145 gcons, 161, 162 gdefn, 176 gdifference, 160, 162 gdiv, 156, 161 gequal, 152–154, 157, 161, 172, 174 gf, 270, 274 gf adp, 272 gf all, 273 gf each, 272 gf element list, 274 gf element type, 273 gf modifiers, 271 gf prec, 175 gf selectors, 272 gf some, 273 gfalse, 145, 152–154, 157, 159 gge, 153, 161 ggt, 153, 161, 169 giff, 154, 161 gimp, 154, 161 gin, 157, 159, 162 gintersect, 159, 162 gione, 145, 166–168, 170 gitwo, 145, 170 gizero, 145, 154 gle, 153, 161, 162 glt, 153, 154, 161, 169 gmap insert, 166 gmapomit, 166 gminus, 151, 152 gmod, 156, 162 gname, 45, 49, 50, 54, 55, 58, 59,

64–66, 70, 71, 142, 143, 183 gne, 152, 161 gnot, 152 gnull map, 170, 171 gnull seq, 170, 171 gnull set, 171 gomit, 158, 162 gor, 153, 161 gplus, 156, 162, 166, 167 gpower, 154, 161 gquotient, 155, 161 grange elements, 150 grcons, 161, 162 grzero, 145, 154 gseq, 150, 151, 161, 167 gseq insert before, 167 gseq insert behind, 167 gseqomit, 166 gset, 150, 151, 158 gset or seq, 151 gstring seq, 147 gsub, 159, 162 gsubtract, 156, 162, 166, 167 gsymbol, 20 gtimes, 155, 161 gtrue, 145, 152–154, 157, 159 gtruep, 145, 154, 157, 159, 162, 169,

172, 174 gunion, 158, 162 gypsy grammar, 17, 19, 20

has defn, 176

ibase, 61, 146 identifier lexeme form, 15 identifier lexemep, 15, 17, 24, 25 identifierp, 17, 18, 45, 49, 50, 55, 58,

59, 64–66, 70, 71, 142, 183 identifierp imp treep, 183 idifference, 7, 157 if else exp, 61, 183 if exp else subtrees car, 181 if test not boolean error, 32 ileq, 7, 115, 129, 131 ilessp, 153 in arg error, 33, 157 in arg type, 147 in map, 10, 23, 85, 174 in type, 124, 129, 130, 145, 147 indeterminate, 117, 130, 147, 162 indeterminate fn result erro

r, 33 index set value set, 105, 107 index typep, 84, 127 indexed value set, 105 ineg, 152 integer desc, 83, 117, 119, 120, 123,

124, 129, 142, 145, 146, 148– 152, 154–174

integer descp, 81, 83 integer typep, 83 integerp, 115, 131 intersect args error, 33, 160 intersection, 8 iplus, 7, 156 ipower, 1, 154 iquotient, 156 iremainder, 156 is digit, 7, 14, 15 is hexdigit, 14, 15 is hexdigit list, 15 is letter, 7, 15 itimes, 1, 155 izerop, 155, 156

key value mapp, 10, 110, 112, 113 key values, 10, 14, 84, 110 keys, 10, 13, 84, 110 kind, 62, 63, 76, 125, 126, 142, 176,

178

last arg error, 34, 168 leaf equal, 21, 181 leaf equal imp tree size eq

ual, 181 leafp, 13, 16–18, 21, 23, 181 length, 8, 9, 14, 16, 55, 67, 76, 101,

104, 110, 118, 125, 126, 132, 144, 150 leq arg list tree size, 184 leq bound id tree size, 184 leq if exp else part, 183 leq object name tree size, 183 lessp arg list tree size, 184 lessp available types, 126 lessp bound id tree size, 184 lessp car imp lessp tree si

ze, 182 lessp cdar tree size, 86 lessp cdr tree size, 86 lessp gname tree size, 183 lessp gname tree size 0, 183 lessp if exp else part, 183 lessp if than elif, 182 lessp key values, 10 lessp keys, 10 lessp list subtree size, 22 lessp list subtree than subt

rees, 85 lessp mapping domain tree si

ze, 85 ze 0, 85

lessp mk tree car imp lessp tree size, 183 lessp object name tree size, 183 lessp plus cdr caar cddar, 106 lessp rcdr, 9 lessp remove length, 9 lessp subtree body size, 22 lessp subtree body than subt

rees, 85 lessp subtree i size, 22 lessp subtree size, 22 lessp subtree than subtrees, 85 lessp subtrees imp lessp tree

size, 181 lexeme, 13, 16, 17, 21, 25, 45, 145–

147, 181 lhs, 20 list cons, 104–106 list subtree, 21, 22, 85 list tree size not zero, 85 listp array desc subtrees, 85 listp cdar imp sub1 count

not zero, 106 listp if exp else subtrees, 182 listp imp count not zero, 106 listp mapping desc subtrees, 85 listp record desc subtrees, 85 listp sequence desc subtrees, 85 listp set desc subtrees, 86 local name, 64, 65, 75, 126 local names, 75 local unit names, 75 lower pred error, 34, 172 lt colon args error, 34

many post conditions error, 34, 67 many scope error, 34, 76 many unit error, 34, 76 map entry, 10, 101, 109, 119, 121 mapped value, 10, 16, 23, 80, 85,

115, 116, 124, 174 mapping desc, 128, 139 mapping descp, 82, 85, 94, 148, 157–

160, 164, 166, 167, 170, 172, 173

mapping get, 148, 150, 157, 164–166 mapping merge arg check, 157–160 mapping merge arg check2, 157, 158 mapping merge error, 35, 103, 104,

158, 160 mapping put, 164–166 mapping selector type error, 35, 128 mapping value set, 106, 108 mark, 117, 129, 147, 166, 167 marked, 77, 117, 130, 131, 145–174,

178, 274 marked typed, 117 marked typed list, 117, 118, 151, 158 marked typed value set, 118, 180 markedp, 77, 117, 118 max arg error, 35, 169 max size, 80, 82, 108, 109, 114, 115,

123, 124 mdigit value, 146 member append, 125 meta f, 274 min arg error, 35, 169 minteger, 146 mk actual, 26, 27 mk actual list, 27 mk arg list, 26, 27 mk array default, 118, 120, 127 mk array desc, 78, 82, 120, 127 mk bound expression, 27, 28 mk component selectors, 27 mk digit list, 24, 25 mk empty, 25 mk entry name, 178 mk entry value, 25, 175 mk entry value lexeme, 24, 25 mk error, 28–45, 125, 129–131, 147,

152, 155–157 mk error decl, 28, 29, 34, 36, 42, 44 mk error kind, 125 mk expression, 26, 175 mk identifier, 24–27, 175 mk identifier lexeme, 24, 25 mk identifier list, 27, 53 mk integer desc, 78, 81, 83 mk literal value, 25 mk mapping desc, 79, 82, 85, 121,

128 mk modified primary value, 26, 175 mk named unit, 26, 66 mk number, 25 mk pending desc, 80, 82, 128 mk primary value, 25–27 mk quantified expression, 28, 53 mk rational desc, 78, 81, 83 mk record default, 118, 120, 128 mk record desc, 79, 82, 120, 128 mk reserved word, 23, 24, 26, 28,

62, 181, 182 mk rhs, 17, 18, 181 mk rhs imp root, 181 mk rule, 18–20 mk scalar const unit, 26, 54 mk scalar desc, 78, 81, 83, 120, 127 mk sequence desc, 79, 82, 121, 128 mk set desc, 79, 80, 82, 85, 94, 113,

121, 128 mk single formal data paramete

r, 26, 59 mk special symbol, 23, 24, 26, 27 mk tree, 11, 23–28, 62, 78–80, 82,

83, 125, 175, 183 mk true expression, 27, 67, 68 mk typed, 116, 117 mk unary operator, 24 mk value modifiers, 27, 175 mref, 75–77, 126 mref result, 126 mutual-base type-field base t

ypes, 120, 121 mutual-dtype-dtype fields-dtype

list, 112–116 mutual-gf-gapply-apply fun-gf

modifiers-gf selectors-gf adp-gf eachgf some-gf all-gf element..., 271–274

mutual-parse tree listp-parse

treep, 19, 20 mutual-type desc-field descs, 138–144 mutual-type equal-field tds eq

ual, 123, 124 mutual-value set-field value

sets, 108, 109 mutual-vmember-vsubsetp-vequal-v

set equal-vsequence equal-vmapping equalvrecord equal-vfields e..., 90– 101

n too small, 35 name already in use error, 35 named unit, 66 named unit list, 66, 74 namelist to actuals, 27, 175 ncopies, 8, 118, 144, 150 negative exponent error, 35, 154 new namep, 174 no function defn error, 36 no scope error, 36, 76 no such component error, 36, 85, 97,

101, 148, 149, 162–165 no such field error, 36, 149 no unit error, 36, 76 non rational simple typep, 84, 105,

151 non simple subrange type er

ror, 36, 131 nonfirst arg error, 36, 170 nonlast arg error, 36, 170 not array error, 36, 148, 163 not binary op error, 36, 162 not defined on type error, 36, 153 not equality type error, 36, 152 not expression error, 37 not function or const error, 37 not in set error, 37, 159 not in type error, 37, 117, 170, 171 not mapping error, 37, 148, 164, 166 not mapping type error, 37, 170 not range error, 37, 129, 130 not record error, 37, 149, 164 not record fields error, 37, 144 not root equal lhs imp not

rule, 125 not selectable error, 38, 101, 150 not sequence error, 38, 149, 163, 165 not sequence type error, 38, 171 not set type error, 38, 171 not type descriptor error, 38, 101, 109,

115, 121 not type error, 38, 143 not unary op error, 38, 152 nth, 8, 101 null map, 84, 121, 128, 170 null seq, 84, 121, 128, 163, 171 null set, 84, 94, 113, 121, 128, 171 null undefined error, 38, 171 number error, 38, 146 number list, 7, 105, 151 number list2, 7 number to char list, 8, 24

object, 77 object name, 66, 183 object namep, 57 omit args error, 38, 159 open bracket lexeme, 14, 16 open paren lexeme, 14, 16 opt default value error, 39, 128 opt size limit error, 39, 129 ord arg error, 39, 172

pair list map, 10, 118, 144 param reserved error, 39, 177 parse tree leafp, 18, 19, 181 parse tree listp, 19 parse treep, 20, 181 pending default value error, 40, 128 pending desc, 128, 140 pending descp, 82 pending in type error, 40, 115 pending type defnp, 67, 140 pending type value set erro

r, 40, 109 postc, 67, 175 prec, 67, 68, 175 precomputable f, 77, 128–130 pred arg error, 40, 172 printable char ordp, 7, 14 prodn, 11, 18, 20, 22, 46–74, 125,

128–130, 138–144, 146, 151, 152, 161, 162, 175, 179, 180, 182–184

prodnp, 20 pt, 20, 274 pt intro, 20 put op, 165

quantifier, 53

range arg error, 40, 172 range limits error, 40, 151 range max, 129, 130, 142 range max setting, 130, 131 range min, 129, 142 range min setting, 130, 131 rational, 1, 83, 145, 155 rational desc, 83, 120, 142, 145, 151, 152, 154–157

rational descp, 81, 83 rational typep, 83, 84 rational value set error, 41, 105 rationalp, 115, 131 rcar, 8, 9, 14–16, 24, 46, 146, 178 rcar rcons, 9 rcdr, 8, 9, 15, 16, 24, 45, 46, 146,

147, 177 rcdr rcons, 9 rcons, 9, 25, 46, 54, 55, 59, 66, 69–

71, 178 rdifference, 157 record desc, 128, 139 record descp, 82, 85, 94, 148, 164 record field names, 69, 70, 144 record get, 148, 150, 165 record put, 163, 165 record value set, 106, 108 reduce, 155 ref, 77, 126, 131, 142, 143, 178 ref scope, 77, 126, 142 ref unit, 77, 126, 131, 142, 143, 178 refed type, 126 remove, 9, 126 remove larger, 104, 107 requal, 1, 93 reserved idp, 74, 76, 174, 177 reserved word lexemep, 14 reserved wordp, 16, 18 reserved words, 12–16, 23, 24, 74 result type, 70 rhs, 20 rleq, 1, 115, 131 rlessp, 1, 153 rneg, 152 root, 13, 16–19, 21–25, 27, 28, 81,

91, 101, 102, 108, 112, 120, 123, 125, 150, 153, 165, 171, 181

rplus, 156 rpower, 1, 155 rquotient, 155 rtimes, 1, 155 rule, 20, 22, 46–74, 125, 128–130,

138–144, 146, 151, 152, 161, 162, 175, 179, 180, 182–184

rule imp lessp subtree i si

ze, 22 rule imp lessp subtree size, 22 rule imp root equal lhs, 125 rule imp treep, 22 rzerop, 155

same leaf imp same tree si ze1, 181 ze2, 181

scalar check, 131, 132 scalar const units, 54, 55 scalar desc, 127, 132 scalar descp, 81, 83 scalar type defnp, 70, 140 scalar typep, 83, 172–174 scalar value list, 54, 55, 140 scale int arg error, 41, 173 scale type arg error, 41, 173 scope id error, 41, 76 scope list, 70, 71, 76, 125, 126 scope name, 71, 75, 125, 126 scope reserved error, 42, 76 select op, 150, 174 selector td, 81, 82, 94, 96, 101–103,

108, 113, 114, 120, 121, 123, 148, 158, 163, 164, 166, 167

sequence desc, 128, 139, 147, 150 sequence descp, 82, 85, 93, 149, 157,

159, 161, 162, 165, 168, 170, 171, 173

sequence get, 149, 150, 162, 165–

168 sequence put, 164, 165 sequence value set, 107, 108 set default value, 131, 141 set desc, 128, 140, 150, 167, 172 set descp, 82, 86, 93, 157–160, 171,

173 set difference, 9, 126 set difference member, 126 set difference remove, 126 set equal, 9, 113, 123 set range, 131, 142 set tmax, 82, 127, 131 set tmin, 83, 127, 131 set udv, 83, 127, 131 set value set, 107, 109 setp, 113, 128 sid, 81, 82, 120, 123, 124 simple descp, 81, 82 simple typep, 83, 84, 131, 153, 169 simple value set, 105, 109 size arg error, 42, 173 size limit, 129, 138–140 size limit error, 42, 129 some reserved idp, 74, 128 special symbol lexeme, 23, 24 special symbol lexemep, 14 special symbol lexemes, 14 special symbol map, 12–14, 16, 23 special symbolp, 16, 18 special symbols, 13, 16 standard ids, 74 std domain, 167 std first, 168 std initial, 168 std last, 168 std lower, 168, 172 std max, 169 std min, 169 std nonfirst, 169 std nonlast, 170 std null, 171 std ord, 171 std pred, 172 std range, 172 std scale, 172 std size, 173 std succ, 174 std upper, 173, 174 string char listp, 15, 16 string char seq, 147 string value lexemep, 16, 17 string valuep, 17, 18, 147 sub args error, 42, 159 subrange desc, 127, 131 subsequence get, 162, 166, 167, 170 subsetp, 9 subst tree, 23, 82, 83, 175, 176 subtree, 22, 46–74, 82, 83, 85, 128–

130, 138–144, 146, 175, 179, 180, 183, 184

subtree body, 22, 80, 81, 85 subtree i, 22, 58, 65, 129, 130, 138,

139, 175, 176 subtreep, 23 subtrees, 13, 18, 19, 21–23, 28, 62,

85, 86, 181–183 succ arg error, 43, 174

t or f, 151 tag, 11, 46–74, 125, 128–130, 138–

144, 146, 151, 152, 161, 162, 175, 179–182

taggedp, 20 tdigit value, 146 tid, 81–83, 115, 120, 123, 124 tmax, 81, 83, 105, 115, 123, 173 tmin, 81, 83, 105, 115, 123, 168 tokenp, 13, 19 tokens, 13 tree equal, 21, 23, 181, 182 tree equal imp tree size eq

ual, 181 tree size, 20–22, 85, 86, 180–184 tree size not zero, 22 treep, 13, 17–19, 21–23, 28, 86, 181,

183 treep type desc, 86 type, 117, 124, 150–153, 157–174 type defn cycle error, 43, 142 type desc, 144, 177, 178, 180 type descp, 82, 84, 86, 91, 101, 108,

112, 119, 120, 123, 147 type equal, 124 type error, 43 type error msg, 81 type in all types, 126 type name expp, 178 type namep, 178 type part, 117 type vequal, 121–124 typed, 116, 117, 119, 145–150, 152, 154–161, 163–174, 178

typedp, 117, 118

uc list, 7, 14–16, 21, 45, 74, 180, 181 uc list tree size, 180 udv, 81, 82, 118, 119, 127, 168 unbounded sequence value set

error, 43, 107 unbounded type error, 44, 169, 173 unbounded value set error, 44, 105 union arg error, 44, 158 unit list, 71–76, 125, 126 unit name, 63–66, 140, 175 unit reserved error, 44, 76 unknown name error, 44, 174 unmark, 77, 117, 118, 130, 131, 147,

149, 164, 168, 171, 173 untag, 20, 125 upper case, 7, 14, 180 upper case tree size, 180 upper succ error, 45, 174 upper undefined error, 45

value, 117, 118, 124, 129, 130, 145, 148, 149, 151–161, 163–167, 169, 170, 172–174, 178

value part, 118 value set, 109, 113, 118 value setting, 130, 131 values, 118, 150 varray equal, 100 varray put, 101, 163 vcomponents, 84, 85, 94, 95, 113 vdifference, 103, 160 vdifference maps, 103, 160 vdomain, 84, 94, 114, 158, 167 vequal, 98, 101–104, 122, 152 vequal list, 100 vfields equal, 99 vindexes, 85, 95, 113 vintersect, 103, 159 vintersect maps, 103, 104, 160 vmap put, 101, 102 vmap remove, 103, 166 vmapped value, 100, 101 vmapped value list, 100 vmapping equal, 99 vmapping put, 102, 164, 166 vmember, 97, 102–104, 157 vrange, 85, 114, 172 vrecord equal, 99 vrecord put, 101, 164 vremove, 103, 159 vselect, 101–104, 148, 149 vselectors, 84, 85 vseq select, 101 vsequence equal, 98 vsequence put, 102, 165 vset, 102, 150 vset equal, 98, 113 vsetp, 102, 113, 114 vsize, 101, 166–168, 170, 173 vsubmapp, 102 vsubp, 102, 159 vsubseq select, 101, 163 vsubseqp, 102 vsubsetp, 97, 98, 102 vunion, 104, 158 vunion maps, 104, 158

zero count imp not list, 106 zero divide error, 45, 155, 156 zero to the zero power err

or, 45, 154