(in-package :pvs)

(defvar *allowed-ids* nil)

(defvar *allowed-typed-names* nil)

(defvar *newline-comments* nil)

(defmacro place-bind (vars place &rest body)

`(destructuring-bind ,vars (coerce ,place 'list) ,@body))

(defun parse (&rest keys)

(let* ((*current-file* (or (cadr (member :file keys))

*current-file*))

(start-time (when *current-file* (get-internal-real-time)))

(*newline-comments* nil)

(*last-escaped-quote-place* nil))

(init-parser)

(multiple-value-bind (term error? place msg args)

(handler-case

(apply #'pvs-parse :return-errors t keys)

#+sbcl

(sb-int:stream-decoding-error (err)

(let ((msg

(format nil

"Error: ~a~%This error usually is due to a character that is not UTF-8~

err *current-file* *current-file* *current-file*)))

(parse-error nil msg))))

(when error?

(let ((pargs (mapcar #'(lambda (arg)

(if (stringp arg)

(protect-format-string arg)

arg))

args)))

(parse-error place (parse-error-msg msg pargs))))

(let* ((nt (cadr (member :nt keys)))

(fn (if nt

(makesym #+(and allegro (version>= 6)) "xt-~(~a~)"

#-(and allegro (version>= 6)) "XT-~a"

(sim-term-op term))

#'xt-adt-or-modules))

(*parsing-or-unparsing* t)

(parsed-object (funcall fn term)))

;;(assert-places-set)

(values parsed-object

(if *current-file*

(realtime-since start-time)

0)

(nreverse *newline-comments*))))))

(defun init-parser ()

(setq *table-bracket-counter* 0)

(setq *double-braces-counter* 0)

(setq *elsif-places* nil)

(setq *operator-places* nil))

(defun parse-error-msg (message args)

(multiple-value-bind (found expected)

(cond ((initial-error? message)

(values (car args) (cadr args)))

((lam-error? message)

(values (cadr args) (car args)))

((medial-error? message)

(values (car args) (cadr args))))

(if found

(format nil "Found '~A' when expecting '~A'~

found expected

(string= found ":")

(when (string= found "AS") found)

(when (and (member found '("::=" "=") :test #'string=)

;; Check that ':=' is expected

(>= (length (string (cadr args))) 2)

(string= (cadr args) ":=" :end1 2))

found)

(when *last-escaped-quote-place*

(let ((line (sbrt::place-linenumber *last-escaped-quote-place*))

(col (sbrt::place-charnumber *last-escaped-quote-place*)))

(format nil "(line ~a, col ~a)" line col))))

(format nil "~?" message args))))

(defun initial-error? (message)

(and (stringp message)

(>= (length message) 16)

(string= message "Initial error." :start1 2 :end1 16)))

(defun lam-error? (message)

(and (stringp message)

(>= (length message) 27)

(string= message "Look ahead set match error." :start1 0 :end1 27)))

(defun medial-error? (message)

(and (stringp message)

(>= (length message) 13)

(string= message "Medial error." :start1 0 :end1 13)))

(defun parse-expr (string)

(init-parser)

(pvs-parse :string string :nt 'expr))

(defun psa (string &optional (nt 'adt-or-modules))

(init-parser)

(pvs-parse :string string :nt nt))

(defun ps (string &optional (nt 'adt-or-modules))

(init-parser)

(let* ((term (pvs-parse :string string :nt nt))

(fn (makesym "XT-~a" (sim-term-op term))))

(funcall fn term)))

(defvar *escaped-operators-used* nil)

(defun xt-adt-or-modules (adt-or-modules)

(mapcar #'(lambda (arg) (funcall #'xt-adt-or-module arg))

(term-args adt-or-modules)))

(defun xt-adt-or-module (adt-or-module)

(let* ((*escaped-operators-used* nil)

(id (ds-vid (term-arg0 adt-or-module)))

(formals (xt-theory-formals (term-arg1 adt-or-module)))

(adt-or-mod (term-arg2 adt-or-module))

(aorm (case (sim-term-op adt-or-mod)

(MODULE (funcall #'xt-module adt-or-mod id))

((DATATYPE CODATATYPE)

(funcall #'xt-datatype (sim-term-op adt-or-mod)

adt-or-mod id))

((DATATYPES CODATATYPES)

(funcall #'xt-datatypes (sim-term-op adt-or-mod)

adt-or-mod id)))))

(setf (id aorm) id

(formals aorm) formals

(place aorm) (term-place adt-or-module))

;;(assert (every #'place (formals aorm)))

(when *escaped-operators-used*

(let ((*current-context* (make-new-context aorm)))

(pvs-info "This theory uses the operator~p ~:*~{~a~^ ~}~

*escaped-operators-used*)))

(when *current-file*

(setf (filename aorm) (pathname-name *current-file*)))

(setf (context-path aorm) *default-pathname-defaults*)

aorm))

(defun xt-datatypes (class datatype &optional id inline)

(let* ((subtypes-term (term-arg0 datatype))

(subtypes (mapcar #'(lambda (st)

(make-instance 'type-name

:id (xt-idop (xt-pidop st))

:place (term-place st)))

(term-args subtypes-term)))

(adtbody (term-arg1 datatype))

(endidop (xt-pidop (term-arg2 datatype)))

(endid (ds-vid (term-arg0 endidop))))

(unless (or (null id)

(eq id endid))

(parse-error endidop

"End id ~a does not match datatype id ~a" endid id))

(multiple-value-bind (imps assuming adtcases)

(xt-adtbody (term-args adtbody))

(check-subtypes-constructors-consistency id subtypes adtcases)

(make-instance (if (or (null id) inline)

(if (eq class 'DATATYPES)

'inline-datatype-with-subtypes

'inline-codatatype-with-subtypes)

(if (eq class 'DATATYPES)

'datatype-with-subtypes

'codatatype-with-subtypes))

:subtypes subtypes

:assuming assuming

:importings imps

:constructors adtcases

:place (term-place datatype)))))

(defun check-subtypes-constructors-consistency (id subtypes adtcases)

(let ((badsubtype (find id subtypes :key #'id)))

(when badsubtype

(parse-error badsubtype "May not use datatype name as a subtype")))

(let ((dup (duplicates? subtypes :test #'same-id)))

(when dup

(parse-error dup "Duplicate subtypes are not allowed")))

(let ((badconstr (find-if #'(lambda (x)

(or (not (typep x 'constructor-with-subtype))

(not (member (subtype x) subtypes

:test #'same-id))))

adtcases)))

(when badconstr

(if (typep badconstr 'constructor-with-subtype)

(parse-error (subtype badconstr)

"The subtype for this constructor was not declared above")

(parse-error badconstr

"Must specify a subtype for this constructor"))))

(let ((badsubtype (find-if-not #'(lambda (s)

(some #'(lambda (a)

(same-id s (subtype a)))

adtcases))

subtypes)))

(when badsubtype

(parse-error badsubtype

"This subtype has no associated constructors"))))

(defun xt-theory-formals (theory-formals &optional decl-formal?)

(mapcan #'(lambda (ta) (xt-theory-formal ta decl-formal?))

(term-args theory-formals)))

(defun change-to-decl-formal (decl)

(change-class decl

(typecase decl

(formal-nonempty-struct-subtype-decl 'decl-formal-nonempty-struct-subtype)

(formal-struct-subtype-decl 'decl-formal-struct-subtype)

(formal-nonempty-subtype-decl 'decl-formal-nonempty-subtype)

(formal-subtype-decl 'decl-formal-subtype)

(formal-nonempty-type-decl 'decl-formal-nonempty-type)

(formal-nonempty-type-appl-decl 'decl-formal-nonempty-type-appl)

(formal-type-appl-decl 'decl-formal-type-appl)

(formal-type-decl 'decl-formal-type)

(formal-const-decl 'decl-formal-const-decl)

(formal-theory-decl 'decl-formal-theory-decl))))

(defun xt-theory-formal (theory-formal &optional decl-formal?)

(let* ((importing (term-arg0 theory-formal))

(idops (xt-check-periods (term-arg1 theory-formal)))

(decl-body (term-arg2 theory-formal)))

(multiple-value-bind (decl dtype)

(xt-declaration-body decl-body)

(when decl-formal?

;; (unless (formal-type-decl? decl)

;; (parse-error theory-formal

;; "Only type declarations allowed for declaration parameters"))

(change-to-decl-formal decl))

(append (unless (is-sop 'THEORY-FORMAL-NULL-1 importing)

(xt-formal-importing-elt importing))

(xt-chained-decls (term-args idops) nil dtype nil decl

theory-formal)))))

(defun xt-datatype (class datatype &optional id inline)

(let* ((adtbody (term-arg0 datatype))

(endidop (xt-pidop (term-arg1 datatype)))

(endid (ds-vid (term-arg0 endidop))))

(unless (or (null id)

(eq id endid))

(parse-error (term-arg1 datatype)

"End id ~a does not match datatype id ~a" endid id))

(multiple-value-bind (imps assuming adtcases)

(xt-adtbody (term-args adtbody))

(make-instance (if (or (null id) inline)

(if (eq class 'DATATYPE)

'inline-datatype

'inline-codatatype)

(if (eq class 'DATATYPE)

'datatype

'codatatype))

:assuming assuming

:importings imps

:constructors adtcases

:place (term-place datatype)))))

(defun xt-adtbody (adtbody &optional imps assuming adtcases)

(if (null adtbody)

(values imps assuming (nreverse adtcases))

(case (sim-term-op (car adtbody))

(ID-THEORY-DECL

(if (or assuming adtcases)

(parse-error (car adtbody) "Cannot have assuming here")

(let ((id (xt-check-periods (term-arg0 (car adtbody))))

(tdecl (xt-theory-decl (term-arg1 (car adtbody)))))

(setf (id tdecl) (xt-idop (xt-pidop id)))

(xt-adtbody (cdr adtbody) (cons tdecl imps) assuming adtcases))))

(IMPORTING-ELT

(if (or assuming adtcases)

(parse-error (car adtbody) "Cannot have assuming here")

(let ((imp (xt-importing-elt (car adtbody))))

(xt-adtbody (cdr adtbody) (append imp imps) assuming adtcases))))

(ASSUMING

(if (or assuming adtcases)

(parse-error (car adtbody) "Cannot have assuming here")

(let ((ass (xt-assumings (car adtbody))))

(xt-adtbody (cdr adtbody) imps ass adtcases))))

(ID-ADTCASE

(let ((adtcase (xt-id-adtcase (car adtbody))))

(xt-adtbody (cdr adtbody) imps assuming (cons adtcase adtcases))))

(t (error "Huh?")))))

(defun xt-id-adtcase (id-adtcase)

(let* ((constrid (term-arg0 id-adtcase))

(dformals (xt-theory-formals (term-arg1 id-adtcase)))

(adtcase (term-arg2 id-adtcase))

(constructor (term-arg0 adtcase))

(recognizer (term-arg1 adtcase))

(constr (xt-constructor constrid constructor))

(subtype (when (is-sop 'ADTCASE-SUBTYPE adtcase)

(xt-check-periods (term-arg2 adtcase))

(make-instance 'type-name

:id (xt-idop (xt-pidop (term-arg2 adtcase)))

:place (term-place (term-arg2 adtcase))))))

(xt-check-periods recognizer)

(when subtype

(change-class constr 'constructor-with-subtype)

(setf (subtype constr) subtype))

(setf (decl-formals constr) dformals)

(setf (recognizer constr) (xt-idop (xt-pidop recognizer)))

(setf (place constr) (term-place constructor))

constr))

(defun xt-constructor (id adtdecls)

(let ((idop (xt-check-periods id)))

(make-instance 'simple-constructor

:id (xt-idop (xt-pidop idop))

:arguments (unless (is-sop 'CONSTRUCTOR-NULL-1 adtdecls)

(xt-adtdecls adtdecls))

:place (term-place-interval id adtdecls))))

(defun xt-adtdecls (decls)

(mapcan #'xt-adtdecl (term-args decls)))

(defun xt-adtdecl (adtdecl)

(let* ((idops (xt-check-periods (term-arg0 adtdecl)))

(type (term-arg1 adtdecl))

(dtype (xt-not-enum-type-expr type)))

(xt-chained-decls (term-args idops)

nil

type

nil

(make-instance 'adtdecl

:declared-type dtype

:place (term-place type))

adtdecl)))

(defun xt-module (theory &optional id)

(let* ((exp-t (term-arg0 theory))

(exp (if (is-sop 'NOEXP exp-t)

(make-instance 'exporting

:kind 'default)

(xt-exporting exp-t)))

(assum-t (term-arg1 theory))

(assum (unless (is-sop 'NOASS assum-t)

(xt-assumings assum-t)))

(tpart-t (term-arg2 theory))

(tpart (unless (is-sop 'NOTHEORY tpart-t)

(xt-theory-part tpart-t)))

(endid (ds-vid (term-arg3 theory))))

(unless (or (null id) (eq id endid))

(parse-error (term-arg3 theory)

"End id ~a does not match theory id ~a" endid id))

;; (assert (every #'place (modules exp)))

;; (assert (every #'place assum))

;; (assert (every #'place tpart))

(let ((th (make-instance 'module

:exporting exp

:assuming assum

:theory tpart

:place (term-place theory))))

(dolist (decl assum)

(when (declaration? decl)

(setf (module decl) th)))

(dolist (decl tpart)

(when (declaration? decl)

(setf (module decl) th)))

th)))

(defun xt-exporting (exporting)

(let ((names (term-arg0 exporting))

(modnames (term-arg1 exporting)))

(make-instance 'exporting

:names (case (sim-term-op names)

(EXPORTING-ALL 'all)

(EXPNAMES (mapcar #'xt-expname (term-args names)))

(t (break "Something's wrong with the parser")))

:but-names (when (and (is-sop 'EXPORTING-ALL names)

(not (is-sop 'NOEXPBUTS (term-arg0 names))))

(mapcar #'xt-expname

(term-args (term-arg0 names))))

:kind (case (sim-term-op modnames)

(EXPMODALL 'all)

(EXPMODCLOSURE 'closure)

(t nil))

:modules (case (sim-term-op modnames)

(NOEXPORTINGMODS nil)

(EXPMODALL nil)

(EXPMODCLOSURE nil)

(t (mapcar #'xt-modname (term-args modnames))))

:place (term-place exporting))))

(defun xt-expname (expname)

(let* ((pid (xt-pidop (term-arg0 expname)))

(id (xt-idop pid))

(kind (term-arg1 expname)))

(make-instance 'expname

:id id

:kind (case (sim-term-op kind)

(NOEXPKIND nil)

(EXPTYPE 'type)

(EXPFORMULA 'formula)

(t (xt-not-enum-type-expr kind)))

:place (term-place expname))))

(defun xt-assuming-part (assumings)

(mapcan #'(lambda (ass)

(if (is-sop 'IMPORTING-ELT ass)

(xt-importing-elt ass)

(xt-assuming ass)))

(term-args assumings)))

(defun xt-assumings (assumings)

(mapcan #'(lambda (ass)

(if (is-sop 'IMPORTING-ELT ass)

(xt-importing-elt ass)

(xt-assuming ass)))

(term-args assumings)))

(defun xt-assuming (assuming)

(let* ((_decl (term-arg0 assuming))

(idops (xt-check-periods (term-arg1 assuming)))

(decl-params (unless (is-sop 'NO-THEORY-FORMALS (term-arg2 assuming))

(xt-theory-formals (term-arg2 assuming) t)))

(formals (term-arg3 assuming))

(pdformals (unless (is-sop 'NOFORMALS formals)

(xt-pdf formals)))

(decl (term-arg4 assuming))

(semi (term-arg5 assuming)))

(when (and (cdr (term-args idops)) pdformals)

(parse-error formals ": expected here"))

(case (sim-term-op decl)

((LIB-DECL THEORY-DECL TYPE-DECL DATATYPE)

(let ((badid (find-if #'(lambda (tid)

(assq (ds-id (term-arg0 tid))

*pvs-operators*))

(term-args idops))))

(when badid

(parse-error badid "Id expected here")))))

(multiple-value-bind (pdecl tdecl)

(xt-declaration-body decl idops)

(let ((decls (xt-chained-decls (term-args idops)

decl-params

tdecl

pdformals

pdecl

assuming)))

(setf (semi pdecl)

(if (is-sop 'SEMIC semi)

(if (is-sop 'ATDECL _decl)

'both t)

(if (is-sop 'ATDECL _decl)

'_decl nil)))

decls))))

(defun xt-theory-part (theory)

(mapcan #'(lambda (decl)

(case (sim-term-op decl)

(IMPORTING-ELT (xt-importing-elt decl))

(JUDGEMENT-ELT (xt-judgement-elt decl))

(CONVERSION-ELT (xt-conversion-elt decl))

(AUTO-REWRITE-ELT (xt-auto-rewrite-elt decl))

(t (xt-theory decl))))

(term-args theory)))

(defun xt-theory (tdecl)

(let* ((_decl (term-arg0 tdecl))

(idops (xt-check-periods (term-arg1 tdecl)))

(decl-params (unless (is-sop 'NO-THEORY-FORMALS (term-arg2 tdecl))

(xt-theory-formals (term-arg2 tdecl) t)))

(formals (term-arg3 tdecl))

(pformals (unless (is-sop 'NOFORMALS formals)

(xt-pdf formals)))

(decl (term-arg4 tdecl))

(semi (term-arg5 tdecl)))

(when (and (cdr (term-args idops)) pformals)

(parse-error formals ": expected here"))

(when (and decl-params

(memq (sim-term-op decl) '(LIB-DECL VAR-DECL)))

(parse-error decl-params "Declaration formals not allowed here"))

(case (sim-term-op decl)

((LIB-DECL THEORY-DECL TYPE-DECL DATATYPE CODATATYPE)

(let ((badid (find-if #'(lambda (tid)

(assq (ds-id (term-arg0 tid))

*pvs-operators*))

(term-args idops))))

(when badid

(parse-error badid "Id expected here")))))

(case (sim-term-op decl)

((DATATYPE CODATATYPE)

(xt-theory-datatype idops decl-params formals decl semi))

((DATATYPES CODATATYPES) ;; with subtypes

(xt-theory-datatypes idops decl-params formals decl semi))

(t (multiple-value-bind (pdecl type-decl)

(xt-declaration-body decl idops)

(let ((decls (xt-chained-decls (term-args idops)

decl-params

type-decl

pformals

pdecl

tdecl)))

#+pvsdebug ; Careful! nil is a valid PVS id

(assert (every #'(lambda (d)

(or (not (const-decl? d))

(id d)))

decls))

(assert (every #'place decls))

(setf (semi pdecl)

(if (is-sop 'SEMIC semi)

(if (is-sop 'ATDECL _decl)

'both t)

(if (is-sop 'ATDECL _decl)

'_decl nil)))

decls))))))

(defun xt-pidop (pidop)

(if (cdr (term-args pidop))

(let ((idop (mk-ergo-term 'IDOP

(list (mk-id (makesym "~{~a~^.~}"

(mapcar #'xt-idop (term-args pidop))))))))

(setf (term-place idop) (term-place pidop))

idop)

(term-arg0 pidop)))

(defun xt-check-periods (pidops)

(let ((nterm (mk-ergo-term (sim-term-op pidops)

(mapcar

#'(lambda (pidop)

(if (is-sop 'IDOPAPPL pidop)

(parse-error pidops "parens not allowed here")

(if (cdr (term-args pidop)) ;; have periods

(if *xt-periods-allowed*

(xt-pidop pidop)

(parse-error pidops

"periods not allowed here"))

(if (is-sop 'PIDOP pidop)

(term-arg0 pidop)

pidop))))

(term-args pidops)))))

(setf (term-place nterm) (term-place pidops))

nterm))

(defun xt-theory-datatypes (idops decl-params formals decl semi)

(cond ((is-sop 'PDF formals)

(parse-error (term-arg0 formals)

"Inline datatypes may not have parameters"))

((cdr (term-args idops))

(parse-error (term-arg0 (term-arg1 idops))

"Only one id allowed for datatypes"))

((not (is-id (term-arg0 (term-arg0 idops))))

(parse-error (term-arg0 idops)

"Datatype identifier must be an id"))

(t (let* ((id (ds-vid (term-arg0 (term-arg0 idops))))

(adt (funcall #'xt-datatypes (sim-term-op decl)

decl id t)))

(setf (id adt) id

(formals adt) (xt-theory-formals formals t)

(decl-formals adt) decl-params

(semi adt) (when (is-sop 'SEMIC semi) t))

(list adt)))))

(defun xt-theory-datatype (idops decl-params formals decl semi)

(cond ((is-sop 'PDF formals)

(parse-error (term-arg0 formals)

"Inline (co)datatypes may not have theory parameters"))

((cdr (term-args idops))

(parse-error (term-arg0 (term-arg1 idops))

"Only one id allowed for datatypes"))

((not (is-id (term-arg0 (term-arg0 idops))))

(parse-error (term-arg0 idops)

"Datatype identifier must be an id"))

(t (let* ((id (ds-vid (term-arg0 (term-arg0 idops))))

(adt (funcall #'xt-datatype (sim-term-op decl)

decl id t)))

(setf (id adt) id

(formals adt) (xt-theory-formals formals t)

(decl-formals adt) decl-params

(semi adt) (when (is-sop 'SEMIC semi) t))

(list adt)))))

(defun xt-importing-elt (importing-elt)

(let* ((importing (term-arg0 importing-elt))

(imp-place (term-place importing))

(importings

(mapcar #'(lambda (item)

(let* ((it-place (term-place item))

(place (vector (starting-row imp-place)

(starting-col imp-place)

(ending-row it-place)

(ending-col it-place))))

(if (is-sop 'THEORY-ABBREVIATION-DECL item)

(make-instance 'theory-abbreviation-decl

:id (xt-idop (xt-pidop (term-arg1 item)))

:theory-name (xt-modname (term-arg0 item))

:place place

:semi (when (is-sop 'SEMIC

(term-arg1 importing-elt))

t)

:chain? t)

(make-instance 'importing

:theory-name (xt-modname item)

:place place

:semi (when (is-sop 'SEMIC

(term-arg1 importing-elt))

t)

:chain? t))))

(term-args importing))))

(setf (chain? (car (last importings))) nil)

importings))

(defun xt-formal-importing-elt (importing)

(let ((lib-decl

(unless (is-sop 'NOLIB (term-arg0 importing))

(break "formal importing with lib: needs fixing")))

(importings

(mapcar #'(lambda (item)

(let* ((imp-place (term-place importing))

(it-place (term-place item))

(place (vector (starting-row imp-place)

(starting-col imp-place)

(ending-row it-place)

(ending-col it-place))))

(if (is-sop 'THEORY-ABBREVIATION-DECL item)

(make-instance 'theory-abbreviation-decl

:id (ds-id (term-arg1 item))

:theory-name (xt-modname (term-arg0 item))

:place place

:chain? t)

(make-instance 'importing

:theory-name (xt-modname item)

:place place

:chain? t))))

(term-args (term-arg1 importing)))))

(setf (chain? (car (last importings))) nil)

(if lib-decl

(cons lib-decl importings)

importings)))

(defun xt-judgement-elt (decl)

(let ((jdecls (xt-judgement (term-arg0 decl))))

(dolist (jdecl jdecls)

(setf (semi jdecl) (when (is-sop 'SEMIC (term-arg1 decl)) t)))

jdecls))

(defun xt-judgement-decl (decl idops)

(multiple-value-bind (jdecls dtype)

(xt-judgement decl)

(cond ((cdr (term-args idops))

(parse-error idops

"May not declare multiple ids for a judgement"))

((cdr jdecls)

(parse-error decl

"May not declare multiple judgements when an id is given"))

(t (values (car jdecls) dtype)))))

(defun xt-judgement (decl)

(let* ((jdecls (term-args (term-arg0 decl)))

(class (ds-id (term-arg1 decl)))

(type (term-arg2 decl))

(dtype (xt-not-enum-type-expr type))

(place (term-place decl)))

(values (case class

(HAS-TYPE

(xt-const-judgement jdecls dtype place))

(SUBTYPE-OF

(xt-subtype-judgement jdecls dtype place))

(REC-HAS-TYPE

(xt-rec-judgement jdecls dtype place))

(REC-SUBTYPE-OF

(parse-error decl

"RECURSIVE not allowed for subtype judgements")))

type)))

(defun xt-subtype-judgement (jdecls dtype place)

(let ((decls (mapcar #'(lambda (jdecl)

(xt-subtype-judgement* jdecl dtype place))

jdecls)))

(setf (chain? (car (last decls))) nil)

decls))

(defun appl-judgement-form? (expr-term)

(cond ((is-sop 'APPLICATION expr-term)

(and (cond ((is-sop 'NAME-EXPR (term-arg0 expr-term))

(and (is-sop 'NOTYPE (term-arg1 (term-arg0 expr-term)))

(is-sop 'NOPRED (term-arg2 (term-arg0 expr-term)))))

((is-sop 'APPLICATION (term-arg0 expr-term))

(appl-judgement-form? (term-arg0 expr-term)))

(t nil))

(is-sop 'FUN-ARGUMENTS (term-arg1 expr-term))

(term-args (term-arg1 expr-term))

(every #'(lambda (fa)

(or (is-sop 'NAME-EXPR fa)

(and (is-sop 'TUPLE-EXPR fa)

(and (term-args fa)

(every #'(lambda (tu) (is-sop 'NAME-EXPR tu))

(term-args fa))))))

(term-args (term-arg1 expr-term)))))

((is-sop 'UNARY-TERM-EXPR expr-term)

(and (cond ((is-sop 'TUPLE-EXPR (term-arg1 expr-term))

(every #'(lambda (fa)

(or (is-sop 'NAME-EXPR fa)

(and (is-sop 'TUPLE-EXPR fa)

(and (term-args fa)

(every #'(lambda (tu) (is-sop 'NAME-EXPR tu))

(term-args fa))))))

(term-args (term-arg1 expr-term))))

(t nil))))

((is-sop 'TERM-EXPR expr-term)

)))

(defun xt-subtype-judgement* (jdecl dtype place)

(cond ((is-sop 'JDECL-EXPR jdecl)

(let* ((*allowed-typed-names*

(appl-judgement-form? (term-arg0 jdecl)))

(ex (xt-expr (term-arg0 jdecl)))

(type (xt-convert-expr-to-type-expr ex)))

(assert (place type))

(make-instance 'subtype-judgement

:declared-subtype type

:declared-type dtype

:chain? t

:place place)))

(t

(assert (is-sop 'JDECL-TYPE jdecl))

(let ((type (xt-type-expr (term-arg0 jdecl))))

(make-instance 'subtype-judgement

:declared-subtype type

:declared-type dtype

:chain? t

:place place)))))

(defun xt-convert-expr-to-type-expr (ex)

(let ((etype (xt-convert-expr-to-type-expr* ex)))

(unless (place etype)

(setf (place etype) (place ex)))

etype))

(defmethod xt-convert-expr-to-type-expr* :around ((ex expr))

(if (plusp (parens ex))

(make-instance 'expr-as-type :expr ex)

(call-next-method)))

(defmethod xt-convert-expr-to-type-expr* ((ex name-expr))

(change-class ex 'type-name))

(defmethod xt-convert-expr-to-type-expr* ((ex set-expr))

(change-class ex 'subtype

:predicate (copy ex)))

(defmethod xt-convert-expr-to-type-expr* ((ex application))

(if (name-expr? (operator ex))

(let* ((tn (change-class (operator ex) 'type-name))

(args (arguments ex)))

(make-instance 'type-application

:type tn

:parameters args

:place (place ex)))

(parse-error (place ex) "Type application must be of the form T(a, b, ...)")))

(defmethod xt-convert-expr-to-type-expr* ((ex expr))

(parse-error ex "Type expected here"))

(defun xt-const-judgement (jdecls dtype place)

(let ((decls (mapcar #'(lambda (jdecl)

(xt-const-judgement* jdecl dtype place))

jdecls)))

(setf (chain? (car (last decls))) nil)

decls))

(defun xt-const-judgement* (jdecl dtype place)

(case (sim-term-op jdecl)

(JDECL-EXPR

(let* ((*allowed-typed-names*

(appl-judgement-form? (term-arg0 jdecl)))

(ex (xt-expr (term-arg0 jdecl))))

(typecase ex

(number-expr

(make-instance 'number-judgement

:number-expr ex

:declared-type dtype

:chain? t

:place place))

(bind-decl

(make-instance 'expr-judgement

:declared-type dtype

:chain? t

:expr ex

:place place))

(name-expr

(make-instance 'name-judgement

:name ex

:declared-type dtype

:chain? t

:place place))

(application

(if (and *allowed-typed-names*

;; Have an application, possibly curried, check if every

;; argument is a name-expr that is not a binding

(some #'(lambda (args)

(some #'bind-decl? args))

(arguments* ex)))

;; Found a typed-name need to convert other name-exprs to

;; untyped-bind-decls

(let* ((invalid-arg (find-if #'(lambda (args) (find-if-not #'name? args))

(arguments* ex)))

(formals (unless invalid-arg

(create-formals-from-arguments (arguments* ex)))))

(if invalid-arg

(parse-error invalid-arg "Must use bindings for application judgements")

(make-instance 'application-judgement

:name (operator* ex)

:formals formals

:declared-type dtype

:chain? t

:place place)))

(make-instance 'expr-judgement

:declared-type dtype

:chain? t

:expr ex

:place place)))

(t (make-instance 'expr-judgement

:declared-type dtype

:chain? t

:expr ex

:place place)))))))

(defun create-formals-from-arguments (args-list &optional formals)

;; args-list should be a list of lists

(if (null args-list)

(nreverse formals)

(let ((args (create-formals-from-arguments* (car args-list))))

(assert (consp args))

(create-formals-from-arguments (cdr args-list) (cons args formals)))))

(defmethod create-formals-from-arguments* ((args cons) &optional formals)

(let ((fml (create-formal-from-argument (car args))))

(assert (bind-decl? fml))

(create-formals-from-arguments* (cdr args) (cons fml formals))))

(defmethod create-formals-from-arguments* ((args null) &optional formals)

(let ((fmls (nreverse formals)))

;; chain? is t by default - reset to nil if there is no following arg

;; or it is in parens

(xt-set-declared-types fmls)

fmls))

(defmethod create-formals-from-arguments* ((args tuple-expr) &optional formals)

;; Not sure this is possible - but break just in case

(declare (ignore formals))

(break "create-formals-from-arguments* (tuple-expr)"))

(defmethod create-formals-from-arguments* ((args t) &optional formals)

(declare (ignore formals))

(parse-error args "Illegal formal parameter"))

(defmethod create-formal-from-argument ((arg name-expr))

(change-class arg 'untyped-bind-decl :chain? t))

(defmethod create-formal-from-argument ((arg bind-decl))

arg)

(defmethod create-formal-from-argument ((arg t))

(break "Bad arg in create-formal-from-argument"))

(defun xt-jexprdecl (jdecl)

(when (and (> (length (term-args (term-arg0 jdecl))) 1)

(xt-lambda-formals-check (term-arg0 jdecl)))

(parse-error (term-arg0 jdecl) "commas not allowed"))

(let ((bindings (xt-lambda-formals (term-arg0 jdecl) nil)))

(make-instance 'expr-judgement

:formals (xt-flatten-bindings (car bindings) 0)

:expr (xt-expr (term-arg1 jdecl)))))

(defun xt-rec-judgement (jdecls dtype place)

(let ((decls (mapcar #'(lambda (jdecl)

(xt-rec-judgement* jdecl dtype place))

jdecls)))

(setf (chain? (car (last decls))) nil)

decls))

(defun xt-rec-judgement* (jdecl dtype place)

(if (eq (sim-term-op jdecl) 'JDECL-EXPR)

(let ((*allowed-typed-names*

(appl-judgement-form? (term-arg0 jdecl))))

(unless *allowed-typed-names*

(parse-error jdecl "Recursive judgements are only for applications"))

(let ((ex (xt-expr (term-arg0 jdecl))))

(cond ((not (application? ex))

(parse-error jdecl "Recursive judgements are only for applications"))

((not (name-expr? (operator* ex)))

(parse-error jdecl "Recursive judgements are only for named applications"))

(t

(let* ((invalid-arg (find-if #'(lambda (args) (find-if-not #'name? args))

(arguments* ex)))

(formals (unless invalid-arg

(create-formals-from-arguments (arguments* ex)))))

(if invalid-arg

(parse-error invalid-arg

"Must use variables or bindings for recursive judgements")

(make-instance 'rec-application-judgement

:name (operator* ex)

:formals formals

:declared-type dtype

:chain? t

:place place)))))))

(parse-error jdecl "Recursive judgements are not for types")))

(defun xt-conversion-elt (decl)

(let ((cdecls (xt-conversion (term-arg0 decl))))

(dolist (cdecl cdecls)

(setf (semi cdecl) (when (is-sop 'SEMIC (term-arg1 decl)) t)))

cdecls))

(defun xt-conversion (decl)

(xt-conversion* (term-args decl) (sim-term-op decl)))

(defun xt-conversion* (exprs convkey &optional result)

(cond ((null exprs)

(setf (chain? (car result)) nil)

(nreverse result))

(t (let ((cdecl (xt-conversion** (car exprs)

(null (cdr exprs))

convkey)))

(xt-conversion* (cdr exprs) convkey

(cons cdecl result))))))

(defun xt-conversion** (texpr last? convkey)

(let ((expr (xt-expr texpr)))

(case convkey

(CONVERSIONPLUS

(make-instance 'conversionplus-decl

:id (when (name-expr? expr) (id expr))

:expr expr

:chain? (not last?)

:place (term-place texpr)))

(CONVERSIONMINUS

(make-instance 'conversionminus-decl

:id (when (name-expr? expr) (id expr))

:expr expr

:chain? (not last?)

:place (term-place texpr)))

(t