Delete obsolete constructs record/class.
tswd
5 years ago
| 297 | 297 | |
| 298 | 298 | ;;; top level modexp printer --------------------------------------------------- |
| 299 | 299 | |
| 300 | (declaim (inline get-context-name)) | |
| 300 | 301 | (defun get-context-name (obj) |
| 301 | 302 | (let ((context-mod (get-object-context obj))) |
| 302 | 303 | (if context-mod |
| 986 | 987 | ;;;----------------------------------------------------------------------------- |
| 987 | 988 | ;;; MODULE NAME |
| 988 | 989 | ;;;----------------------------------------------------------------------------- |
| 989 | ||
| 990 | (declaim (inline get-module-print-name)) | |
| 990 | 991 | (defun get-module-print-name (module) |
| 991 | 992 | (unless (module-p module) (break "internal error, get-module-print-name")) |
| 992 | 993 | (let ((name (module-name module))) |
| 46 | 46 | ;;;***************************** |
| 47 | 47 | ;;; Application form constructor________________________________________________ |
| 48 | 48 | ;;;***************************** |
| 49 | ||
| 50 | (defmacro method-is-object-constructor (__method__) | |
| 51 | `(eq (method-constructor ,__method__) ':object)) | |
| 52 | ||
| 53 | (defmacro method-is-record-constructor (__method__) | |
| 54 | `(eq (method-constructor ,__method__) ':record)) | |
| 55 | ||
| 56 | (defmacro make-applform-simple (_sort _meth &optional _subterms) | |
| 57 | `(make-application-term ,_meth ,_sort ,_subterms)) | |
| 58 | ||
| 49 | (declaim (inline make-appl-form)) | |
| 59 | 50 | (defun make-applform (sort meth &optional args) |
| 60 | (declare (type sort* sort) | |
| 61 | (type method meth) | |
| 62 | (type list args)) | |
| 63 | (make-applform-simple sort meth args)) | |
| 51 | (declare (optimize (speed 3) (safety 0))) | |
| 52 | (make-application-term meth sort args)) | |
| 64 | 53 | |
| 65 | 54 | ;;; ****************** |
| 66 | 55 | ;;; RESET-REDUCED-FLAG--------------------------------------------------------- |
| 140 | 129 | (declare (type term term) |
| 141 | 130 | (values (or null t))) |
| 142 | 131 | (and (term? term) |
| 143 | (let ((sort (term$sort (term-body term)))) | |
| 132 | (let ((sort (term-sort term))) | |
| 144 | 133 | (and (not (sort= *bottom-sort* sort)) |
| 145 | 134 | (sort<= sort *syntax-err-sort* *chaos-sort-order*))))) |
| 146 | 135 | |
| 194 | 183 | (declare (type method head) |
| 195 | 184 | (type list subterms) |
| 196 | 185 | (values term)) |
| 197 | (make-applform-simple *type-err-sort* head subterms)) | |
| 186 | (make-applform *type-err-sort* head subterms)) | |
| 198 | 187 | |
| 199 | 188 | (defun make-inheritedly-ill-term (head subterms) |
| 200 | 189 | (declare (type method head) |
| 201 | 190 | (type list subterms) |
| 202 | 191 | (values term)) |
| 203 | (make-applform-simple *type-err-sort* head subterms)) | |
| 192 | (make-applform *type-err-sort* head subterms)) | |
| 204 | 193 | |
| 205 | 194 | ;;; TERM-ERROR-OPERATORS&VARIABLES |
| 206 | 195 | ;;; returns the list of error operators contained in term. |
| 1709 | 1709 | (flet ((make-form (sort method arg-list) |
| 1710 | 1710 | (make-applform sort method arg-list))) |
| 1711 | 1711 | (let ((result nil)) |
| 1712 | (if *fill-rc-attribute* | |
| 1713 | (let ((attrpos nil) | |
| 1714 | (class nil)) | |
| 1715 | (if (method-is-object-constructor method) | |
| 1716 | (progn (setf attrpos 2) (setf class t)) | |
| 1717 | (when (method-is-record-constructor method) | |
| 1718 | (setf attrpos 1))) | |
| 1719 | (if attrpos | |
| 1720 | (let ((attrs (nth attrpos arg-list)) | |
| 1721 | (cr-sort (method-coarity method))) | |
| 1722 | (when class | |
| 1723 | (replace-class-id-with-var cr-sort arg-list)) | |
| 1724 | (if attrs | |
| 1725 | (cond ((sort= (term-sort attrs) *attribute-list-sort*) | |
| 1726 | (let* ((attr-method (term-head attrs)) | |
| 1727 | (sv-pairs (list-ac-subterms attrs | |
| 1728 | attr-method)) | |
| 1729 | (flg nil)) | |
| 1730 | (dolist (sv-pair sv-pairs) | |
| 1731 | (block next | |
| 1732 | (when (sort= (term-sort sv-pair) | |
| 1733 | *attribute-list-sort*) | |
| 1734 | (setf flg t) | |
| 1735 | (return-from next nil)) | |
| 1736 | ;; normal sv-pair | |
| 1737 | (replace-attr-id-with-var cr-sort sv-pair))) | |
| 1738 | (unless flg | |
| 1739 | (when (or *parsing-axiom-lhs* | |
| 1740 | *parse-lhs-attr-vars*) | |
| 1741 | ;; (break "1") | |
| 1742 | (setq *parse-lhs-attr-vars* t) | |
| 1743 | (setf (nth attrpos arg-list) | |
| 1744 | (make-right-assoc-normal-form | |
| 1745 | attr-method | |
| 1746 | (nconc sv-pairs | |
| 1747 | (list | |
| 1748 | *attribute-list-aux-variable*)))))) | |
| 1749 | (setq result (make-form sort method arg-list)) | |
| 1750 | result)) | |
| 1751 | (t ;; single sv-pair & not list of attribure. | |
| 1752 | (replace-attr-id-with-var cr-sort attrs) | |
| 1753 | (when (or *parsing-axiom-lhs* | |
| 1754 | *parse-lhs-attr-vars*) | |
| 1755 | ;; (break "2") | |
| 1756 | (setq *parse-lhs-attr-vars* t) | |
| 1757 | (setf (nth attrpos arg-list) | |
| 1758 | (make-applform | |
| 1759 | *attribute-list-sort* | |
| 1760 | *attribute-list-constructor* | |
| 1761 | (list attrs | |
| 1762 | *attribute-list-aux-variable*)))) | |
| 1763 | (setq result (make-form sort method arg-list)) | |
| 1764 | result)) | |
| 1765 | ;; no attributes | |
| 1766 | (progn | |
| 1767 | (setq result (make-form sort method arg-list)) | |
| 1768 | ))) | |
| 1769 | (progn | |
| 1770 | (setq result (make-form sort method arg-list)) | |
| 1771 | ))) | |
| 1772 | ;; normal term | |
| 1773 | (setq result (make-form sort method arg-list))) | |
| 1712 | ;; normal term | |
| 1713 | (setq result (make-form sort method arg-list)) | |
| 1774 | 1714 | ;; special treatment of if_then_else_fi |
| 1775 | 1715 | ;; special treatment of generic operators |
| 1776 | 1716 | (when (eq (term-head result) *bool-if*) |